VBA Makro kopírování položek z více listů do jednoho

[dvbuser]

Dobrý den,
rád bych požádal o pomoc z makrem, které by po spuštění na listu "seznam" (tlačítkem), prohledalo všechny listy ("data" až "dataX") v daném souboru a vložilo všechny položky u kterých jsou zadané počty kusů (sloupec G) do seznamu pod sebe. Pro lepší pochopení přikládám soubor, který již makro obsahuje, toto makro funguje pouze při spuštění na určitém listu ale nejsem schopný ho upravit tak aby procházelo všechny listy.
Děkuju za jakoukoli radu či nápad.

Kód: Vybrat vše

Sub vkladani_polozek()
Sheets("seznam").Range("a4:g250").ClearContents
    poc = 0
    For i = 4 To 1000
            If Cells(i, 7).Value <> "" Then
            'cteni z ceniku
            kod = Cells(i, 1)
            nazev = Cells(i, 2)
            cena = Cells(i, 5)
            ks = Cells(i, 7)
            'zapis do seznamu
            Sheets("seznam").Cells(4 + poc, 1) = kod
            Sheets("seznam").Cells(4 + poc, 2) = nazev
            Sheets("seznam").Cells(4 + poc, 3) = cena
            Sheets("seznam").Cells(4 + poc, 4) = ks
           
            poc = poc + 1
       
        End If
       
        Next
End Sub


[Reklama]

[cmuch]

Toto makro vlož na list "seznam" a pak ho přiřaď tomu tlačítku

Kód: Vybrat vše

Sub vkladani_polozek()
  Dim Sh As Worksheet
  Dim i As Integer, poc As Integer

  Application.ScreenUpdating = False
 
  Sheets("seznam").Range("a4:g" & Cells(Rows.Count, "A").End(xlUp).Row + 1).ClearContents
  poc = 0
   
  For Each Sh In Worksheets
    With Sh
      If .Name Like "data*" Then
        For i = 4 To .Cells(.Rows.Count, "A").End(xlUp).Row
          If .Cells(i, 7).Value <> "" Then
            'zapis do seznamu
            Sheets("seznam").Cells(4 + poc, 1) = .Cells(i, 1) 'kod
            Sheets("seznam").Cells(4 + poc, 2) = .Cells(i, 2) 'nazev
            Sheets("seznam").Cells(4 + poc, 3) = .Cells(i, 5) 'cena
            Sheets("seznam").Cells(4 + poc, 4) = .Cells(i, 7) 'ks
           
            poc = poc + 1
          End If
        Next
      End If
    End With
  Next
 
  Application.ScreenUpdating = True
End Sub

[guest]

K zamyšlení: V případě jasně definovaného poštu listů přistupovat k listům databázově (dotaz bude obsahovat UNION ALL a test pro sloupec G).