vba kode til flytte data mellem ark

Skal den søge i ark 1-16 efter rækker hvor kolonne f indeholder et tal mellem 1 og 52, eller skal den kopiere række 1-52?

Skal rækkerne stå over hinanden med et mellemrum, eller ved siden af hinanden med et mellemrum?

den skal kopiere rækker fra kolonne A til F hvor f indholder tal mellem 1 til 52
Rækkerne skal stå under hinanden mellemrum kommer efter den har koperet data fra sheet 1, mellemrum data sheet 2, osv.

Hvis den bare skal kopiere området A1:F52 burde følgende kunne gøre det..  men har ikke en Excel her, så har desværre ikke testet det.

x = 1
For n=1 to 16
  ThisWorkbook.Sheets(n).Range("A1:F52").Copy Destination:= ThisWorkbook.Sheets(17).Range("A" & x & ":F" & x+51)
  x = x + 53
Next

Kan igen ikke teste - men burde virke!

DestLine = 1
For n=1 to 16
  LastRow = Range("F65536").End(xlUp).Row
    For m=1 to LastRow
      If ThisWorkbook.Sheets(n).Range("F" & m).Value <= 52 And ThisWorkbook.Sheets(n).Range("F" & m).Value >=1 then
        ThisWorkbook.Sheets(n).Range("A" & m & :F" & m).Copy Destination:= ThisWorkbook.Sheets(17).Range("A" & DestLine & :F" & DestLine)
        DestLine = DestLine + 1
      End if
    Next
  DestLine = DestLine + 1
Next

Hov der var en fejl - undskyld!

DestLine = 1
For n=1 to 16
  LastRow = ThisWorkbook.Sheets(n).Range("F65536").End(xlUp).Row
    For m=1 to LastRow
      If ThisWorkbook.Sheets(n).Range("F" & m).Value <= 52 And ThisWorkbook.Sheets(n).Range("F" & m).Value >=1 then
        ThisWorkbook.Sheets(n).Range("A" & m & :F" & m).Copy Destination:= ThisWorkbook.Sheets(17).Range("A" & DestLine & :F" & DestLine)
        DestLine = DestLine + 1
      End if
    Next
  DestLine = DestLine + 1
Next

For F****N også! - Jeg er da for blød i dag - endnu to fejl! Undskyld igen!

DestLine = 1
For n=1 to 16
  LastRow = ThisWorkbook.Sheets(n).Range("F65536").End(xlUp).Row
    For m=1 to LastRow
      If ThisWorkbook.Sheets(n).Range("F" & m).Value <= 52 And ThisWorkbook.Sheets(n).Range("F" & m).Value >=1 then
        ThisWorkbook.Sheets(n).Range("A" & m & ":F" & m).Copy Destination:= ThisWorkbook.Sheets(17).Range("A" & DestLine & ":F" & DestLine)
        DestLine = DestLine + 1
      End if
    Next
  DestLine = DestLine + 1
Next

den skal ikke kopere område A1 til F52, der er 100 vis af rækker, den skal kopiere rækker over som indholder tal 1 til 52 sammen med rækker ved siden af

Og det skulle sidste nye udgave meget gerne gøre! :)

Fandt lige min arbejds-bærbar frem og testede. Den virker! :)

Private Sub CopyToSht17()
DestLine = 1
For n=1 to 16
  LastRow = ThisWorkbook.Sheets(n).Range("F65536").End(xlUp).Row
    For m=1 to LastRow
      If ThisWorkbook.Sheets(n).Range("F" & m).Value <= 52 And ThisWorkbook.Sheets(n).Range("F" & m).Value >=1 then
        ThisWorkbook.Sheets(n).Range("A" & m & ":F" & m).Copy Destination:= ThisWorkbook.Sheets(17).Range("A" & DestLine & ":F" & DestLine)
        DestLine = DestLine + 1
      End if
    Next
  DestLine = DestLine + 1
Next
End Sub

For satan da det virker på dummy databasen som jeg har lavet! Så må jeg igang og afprøve det på den rigtige senere. Jeg siger mange mange tak.

Jamen velbekomme! Må hellere poste den rigtige løsning som et "svar" :)

Private Sub CopyToSht17()
DestLine = 1
For n=1 to 16
  LastRow = ThisWorkbook.Sheets(n).Range("F65536").End(xlUp).Row
    For m=1 to LastRow
      If ThisWorkbook.Sheets(n).Range("F" & m).Value <= 52 And ThisWorkbook.Sheets(n).Range("F" & m).Value >=1 then
        ThisWorkbook.Sheets(n).Range("A" & m & ":F" & m).Copy Destination:= ThisWorkbook.Sheets(17).Range("A" & DestLine & ":F" & DestLine)
        DestLine = DestLine + 1
      End if
    Next
  DestLine = DestLine + 1
Next
End Sub