VLOOKUP...automaticky posun o dalsi stlpec Vyřešeno

[marek26]

ahoj

toto makro urobi to ze funkciu vlookup pouzije v bunke D2 a potiahne dole nakoniec tab.
Ako zabezpecit to ze nech automaticky o dalsi mesiac bude robit presne to iste s tym ze vlookup zacne na bunke marec cize E2.
Range("D2").Select by malo byt inak definovane napr. select first free cell after D2? neviem vsetko ostatne sa nemeni.
Najprv vlookup je za januar potom febr. .....dec 12x to musim robit. preto ak sa to da osetrit nejakou formulaciou "dalsia volna bunka v poradi"
dik

Workbooks.Open Filename:="C:\Users\marek\Desktop\ciel.xls"
Workbooks.Open Filename:="C:\Users\marek\Desktop\zdroj.xls"
Windows("ciel.xls").Activate
Range("D2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(C[-2],[zdroj.xls]zakaznik!C1:C2,2,0)"
Selection.AutoFill Destination:=Range("D2:D12")
Range("D2:D12").Select
Range("D2").Select
End Sub

[Reklama]

[d1amond]

POkud budeš chtít automatiku v posunu na další volnou buňku a následné doplnění, neobejde se to bez definice proměnných. Bylo by lepší dát sem příklad v excelovských sešitech. Jinak tu nahážem 10 procedur, protože to každý pochopí jinak a po svém.

[marek26]

tak som prilozil, prilohy (zdroj- odkial sa tahaju data) a (ciel - prihadzuju sa data na zaklade stlpca ico -bunka A) ale povode som myslel ze namiesto Range(D2) select bude formula +1 cell alebo tak ze to bude stacit.

dakujem

[d1amond]

Ano, to by stačilo, ale jen pro aktivaci buňky. Jak by se informace o "začátku" předala dál? Nyní jsou všechny hodnoty Range napevno danné. Ale my je potřebujeme měnit podle první prázdně buňky.

[marek26]

existuje takova moznost?

[d1amond]

Jinak bych to tu nepsal Podívám se na to večer.

[marek26]

asi je to troska slozitejsie

[d1amond]

Není, jen jsem na to jetě nedostal Napravím to co nejdříve

[marek26]

dakujem ti d1amond budem rad

[d1amond]

Teď jsem na to koukal. Používáš VLOOKUP proč? Nebude někdy souhlasit Název položky ze sešitu zdroj s názvem položky v sešitu cíl neo opačně(počtem nebo názvem)? Pokud by to mělo kopírovat data 1:1, bylo by to opravdu jednoduché procházení a kopírování. Jinak to samozřejmě lze kontrolovat, zda název položky zdroje odpovídá názvu z cíle.
Rovněž by nebylo nutné hledat zdlouhavě následující prázdný sloupec, když jde o pravidelný měsíc. Stačí zjistit číslo aktuální měsíce a podle toho vybrat sloupec který se naplní daty.

[marek26]

no potesim ta, nie podla nazvu ale podla pola "ico" stlpec A bude porovnanaci, (ico bude synchronizacny stlpec ), dalej
ano mas pravdu, januar je pevne stanoveny napr. stlpec "C" (febr="D", marec="E" ......dec="N")
tu dole su 2 prilohy aktualne ako by to mohlo byt:

v tab. CIEL su 2 listy(zosity) = "obrat" , "vynos"
prosim skus to nasledovne:
nech "obrat" (zdroj.xls stlp. "C") da do zosita "obrat" v ciel.xls stlp.C
nech "vynos" (zdroj.xls stlp. "D") da do zosita "vynos" v ciel.xls stlp.C

zdroj.xls stlp. "C"a"D" sa nemeni pozicne, v kazdom mesiaci je na rovnkej pozicii (februar bude tiez C,D,) tie udaje sa len aktualizuju

dufam ze je to zrozumitelne

dakujem

[d1amond]

ObratVynos.zip

(21.08 KiB) Staženo 17 x

Hotovo. Pro otestování jsem v ciel.xls na listu obrat dal do buňky B1 datum, který si můžeš zkusit měnit a zjišťovat co se děje.
Procedura je v sešitu ciel.xls. Na začátek je kontrola, zda je otevřený sešit zdroj.xlx (když ne, končí hláškou) a zda existují listy "obrat" a "vynos". Z datumu se vezme číslo měsíce = číslo sloupce pro naplnění daty.
Nezajímá mě počet ICO ve zdroj.xls, primárně procházím sloupec A v ciel.xls a následně hledám tyto hodnoty ve zdroj.xls - sloupec A. Pokud nenajdu shodu, pokračuji dalším řádkem(ICO) v ciel.xls. Lze libovolne do obou sešitů přidávat firmy, při neshodě se údaj přeskakuje.
pokud vše pojede jak má, smaž v kódu mes = Month(wsh2.Cells(1, 2).Value) ' a bude se brát aktuální měsíc - lze provádět v jednom měsíci opakovaně, naplnění se vždy aktuální hodnoty.

Kód: Vybrat vše

Option Explicit
Sub VynosyObraty()
Dim col As Byte 'radek pro doplneni
Dim mes As Byte 'mesic
Dim wbk1 As Workbook
Dim wbk2 As Workbook
Dim wsh1 As Worksheet 'zdroj
Dim wsh2 As Worksheet 'obrat
Dim wsh3 As Worksheet 'vynos
Dim r1 As Integer
Dim r2 As Integer
Dim ico As String
Dim rng As Range
Dim obrat As Variant
Dim vynos As Variant

Dim errMsg As String

Application.ScreenUpdating = False
On Error Resume Next

errMsg = ""

'nastaveni souboru
Set wbk1 = Workbooks("zdroj.xls")
Set wbk2 = ThisWorkbook

'nastaveni listu
Set wsh1 = wbk1.Worksheets(1)
Set wsh2 = wbk2.Worksheets("obrat")
Set wsh3 = wbk2.Worksheets("vynos")

On Error GoTo err
'kontroly sesitu a listu
If wbk1 Is Nothing Then
    errMsg = errMsg & Chr(10) & Chr(13) & "Nie je otvoreny zdrojovy zosit!"
    GoTo err
End If
If wsh2 Is Nothing Then
    errMsg = errMsg & Chr(10) & Chr(13) & "Harok obrat neexistuje!"
    GoTo err
End If
If wsh3 Is Nothing Then
    errMsg = errMsg & Chr(10) & Chr(13) & "Harok vynos neexistuje!"
    GoTo err
End If


mes = Month(wsh2.Cells(1, 2).Value) 'mes = CByte(Month(Date)) 'aktualni mesic

'podle mesice se nastavi cislo sloupce col
Select Case mes
Case 1: col = 4
Case 2: col = 5
Case 3: col = 6
Case 4: col = 7
Case 5: col = 8
Case 6: col = 9
Case 7: col = 10
Case 8: col = 11
Case 9: col = 12
Case 10: col = 13
Case 11: col = 14
Case 12: col = 15
End Select

'najde prvni radek s ico od konce
r2 = wsh2.Cells(Rows.Count, 1).End(xlUp).Row

Do While r2 > 1
    ico = Trim(CStr(wsh2.Cells(r2, 1).Value))
   
    'hleda shodu ico ve zdroji
    wsh1.Activate
    With wsh1.Range("A:A")
        Set rng = .Find(What:=ico, _
                  After:=.Cells(1), _
                  LookIn:=xlValues, _
                  LookAt:=xlWhole, _
                  SearchOrder:=xlByRows, _
                  SearchDirection:=xlPrevious, _
                  MatchCase:=False)
       
        If Not rng Is Nothing Then 'je nalezena shoda
            r1 = rng.Row
            obrat = .Cells(r1, 3).Value
            vynos = .Cells(r1, 4).Value
        Else: GoTo dalsi 'neni nalezena shoda - dalsi ico
        End If
    End With
   
    'doplneni vynosu a obratu do cilovych listu
    wsh2.Activate
    wsh2.Cells(r2, col).Value = obrat
    wsh3.Activate
    wsh3.Cells(r2, col).Value = vynos
       
    GoTo dalsi

dalsi:
    r2 = r2 - 1
Loop

Application.ScreenUpdating = True
wsh2.Activate

'regulerni konec procedury
Exit Sub

'konec procedury s chybou
err:
MsgBox errMsg, vbCritical
Exit Sub

End Sub


//nevěděl jsem jak chceš proceduru pouštět, takže zatím ručně přes Spustit makro. Dá se to doplnit na tlačítko, otevření sešitu, změny, atd...