VBA - vykopírování dat

[Lůjík]

Ahoj

byl by tu prosím někdo ochotný mi poradit? Potřebovala bych vykopírovat data z ruzných listů (seznam těchto listů je na listu settings, sloupec K) pod sebe. Někdy na těchto listech ale nejsou data, což by se asi dalo ošetřit takto:

If Range("A2") <> "" Then
Range ("A2" & Rows.Count.End(xlUp).Row.Select)
Sheets("NAVISYS").Select

pokud jsou, mají pokaždý jiný počet řádků a potřebovala bych je nakopírovat pod sebe na list NAVISYS... někdo ochotný mi poradit, moc prosím?

[Reklama]

[MePExG]

To by išlo aj pomocou Power Query. Ak dáte súbor so skutočnou štruktúrou, tak Vám to môžem pripraviť.

[Lůjík]

Děkuji moc, ale bohužel jde o citlivá data o zaměstnancích :( Já jsem ve VBA začátečník, ale oc je prosím Power Query?

[MePExG]

PQ je doplnok od verzie 2010 a od v. 2016 je už súčasťou MSE. Stačí zachovať hlavičky a údaje 2-3 riadky vymyslené (aspoň dva listy) a vložiť ako prílohu pri úplnom editore.

[Lůjík]

Děkuju moc, vážím si každé pomocné ruky :) Ale přesto bych to chtěla přes klasické VBA - učím se v něm a tohle je na mě asi moc high-tech :) Zatím mám toto, jen potřebuji zakomponovat Loop... :

Sub End_of_month2()
'makro na vykopírování dat pro list NAVISYS
'Dim i As Integer

Sheets("settings").Select
Range("K1").Select
Sheets(Range("K1").Value).Select

If Range("A2") <> "" Then
Rows(2).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

Else
End If

Sheets("NAVISYS").Select

Range("A" & Rows.Count).End(xlUp).EntireRow.Offset(1, 0).Select
ActiveSheet.Paste

Sheets("settings").Select
Sheets(ActiveCell.Offset(1, 0).Value).Select

'Loop

End Sub

[elninoslov]

Priložte nejakú prílohu, nech je jasnejšie, čo tým myslíte, a hlavne aké je rozloženie dát, či sú medzi riadkami dátových listov medzery, či môže nastať neexistencia listu, a treba chytať chyby a pod...
Zjednodušený príklad:

Kód: Vybrat vše

Sub End_of_month2() 'makro na vykopírování dat pro list NAVISYS
Dim RS As Long, arS()
Dim i As Long, RW As Long

    'načítanie zoznamu listov
    With wsSettings                                 'pracuj s listom Settings
        RS = .Cells(Rows.Count, "K").End(xlUp).Row  'počet riadkov zoznamu listov (podľa popisu nieje hlavička)
        If RS = 1 Then                              'počet 1 dostaneme aj keď je 0 aj 1
            ReDim arS(1 To 1, 1 To 1)               'jednoprvkové pole nemôžeme priradiť priamo, tak ho vytvoríme
            arS(1, 1) = .Range("K1").Value          'a potom doň priradíme hodnotu
        Else
            arS() = .Range("K1:K" & RS).Value       'viacprvkové pole zaplníme rovno
        End If
    End With
   
    'prechádzanie listov a kopírovanie hodnôt
    For i = 1 To RS                                 'prejdeme všetky prvky poľa listov
        If Not IsEmpty(arS(i, 1)) Then              'spracuj list iba ak je prvok poľa neprázdny (ošetrenie vynechania alebo žiadneho riadka)
            With Worksheets(arS(i, 1))              'pracuj s listom podľa indexu
                RW = .Cells(Rows.Count, "A").End(xlUp).Row - 1  'počet riadkov v danom liste (nepredpokladá medzery medzi riadkami, a hlavička sa vynechá)
                If RW > 0 Then                      'ak sú v stĺpci A nejaké data
                    wsNAVISYS.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(RW).Value = .Cells(2, 1).Resize(RW).Value    'tak ich nakopíruj pod posledné data v stĺpci A v liste NAVISYS
                End If
            End With
        End If
    Next i
End Sub