Gegevens vullen tot laatst gevulde cel

[HWV]

Beste,

Ik heb formulieren waar ik de data uit wil hebben.
Het eerste stuk van de code gaat en werkt dat is alles van de active worksheet vanaf regel
24 tot de eerst lege cel te kopieeren en te plakken in een ander Workbooks("Verzamel.xls").Sheets("Opslag").

Nu wil ik uit het active workbook cel A3 kopieren en deze pakken in Workbooks("Verzamel.xls").Sheets("Opslag").
in kolom A, begin bij het eerst lege veld in kolom A en stopt bij de laast gevulde cel in kolom A.

Sub Verplaats()

Range("A24:D" & Cells(Rows.Count, 2).End(xlUp).Row).Copy
Workbooks("Verzamel.xls").Sheets("Opslag").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues

Cells("A3:A3").Copy
Workbooks("Verzamel.xls").Sheets("Opslag").Range("A2:A" & Cells(Rows.Count, 2).End(xlUp).Row).PasteSpecial xlValues

End Sub

Restultaat.

Klantnummer_____Artikel
123456_________1001
123456_________2568
123456_________2689
123456_________3589
123456_________12298
123456_________36985
968965_________1001
968965_________2568
968965_________2689
968965_________3589
968965_________12298
968965_________36985

Vervolg code zal worden dat alles uit een map gehaald wordt en deze code uit voert en het betsand weer sluit

Sub verzamel()

    c0 = Dir("" & Padnaam & "\*.xls")
    Do
                 
      With Workbooks.Add("" & Padnaam & "\" & c0)
      
  Code
  
      End With
      c0 = Dir
    Loop Until c0 = ""
    
    Active.Workbook.Close SaveChanges:=False
    
End Sub

Groet HWV

 

[HWV]

Gelukt

Beste,

Ik heb het voor elkaar gekregen

Sub Verplaats()

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

Range("A24:H" & Cells(Rows.Count, 2).End(xlUp).Row).Copy
Workbooks("Verzamel.xls").Sheets("Opslag").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues

Dim Klantnummer
Set Klantnummer = Range("A3")


Windows("Verzamel.xls").Activate
Sheets("Opslag").Select

For i = 2 To Range("B65000").End(xlUp).Row
   If Cells(i, 1) = "" Then
   Cells(i, 1) = Klantnummer
   End If
   
Next i

With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
End With

End Sub

En met de volgende code haal ik alle 400 bestanden uit een map, doe de code.(Code SNB)

Sub verzamel()

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

    c0 = Dir("H:\Klanten\Klant7\*.xls")
    Do
                 
      With Workbooks.Add("H:\Klanten\Klant7\" & c0)
      
JuistePrijs 'hier zet je de juiste prijs achter de regel
Verplaats ' hier veplaats je de bestanden uit de map in werkmap Verzamel.xls
  
      End With
      c0 = Dir
    Loop Until c0 = ""
    
With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
End With

End Sub