VBA Zellen suchen und kopieren

[joko]

Hi Leute,


habe mir ein VBA geschrieben das mir files in einem ordner findet und die dateinamen ausliest.

Nun hab ich weiter in VBA geschrieben, dass er alle diese files durchgehen soll und mir jede Zeile in der "e1_100" steht kopieren soll. Diese Zeilen werden dann in der Ausgabe einfach untereinander eingefügt.


Leider funktioniert das ganze noch nicht, ich glaube ich hab ein Range-problem. Meine Urpsrungsfiles haben 5 spalten, A-E.

Die neue grosse Excel hat ebenfalls 5 spalten zum einfügen von A-E.


Kann mir einer helfen was ich falsch mache? mit dem Code hier kopiert er mir immer nur die erste Zeile jedes files.. das heisst er scannt gar nicht nach e1_100.

Code:

Sub Import_Function()

Dim Input_WS As Workbook
Dim Output_WS As Workbook
Dim Location As String
Dim i As Long

'Workbook vorbereiten
Set Output_WS = ActiveWorkbook
ActiveSheet.Range("A2:E999999").Clear

'Input-Workbook kommt über Schleifen
For i = 2 To InputBox("Wieviele Input-Blätter gibt es?") + 1
   Output_WS.Sheets(1).Activate
   Location = Cells(i, "H").Value
   Workbooks.Open Filename:=Location
   Set Input_WS = ActiveWorkbook
   
   'Datenimport Teil 1: Range auslesen
   If i = 2 Then
       Zielzeile = 2
   Else:
       Zielzeile = Output_WS.Sheets(1).Range("A1").End(xlDown).Row + 1
   End If
       
   'Filter einstellen
   Input_WS.Sheets(1).Range("A1:E" & Input_WS.Sheets(1).Range("A1").End(xlDown).Row). _
AutoFilter
   Input_WS.Sheets(1).Range("A1:E" & Input_WS.Sheets(1).Range("A1").End(xlDown).Row). _
AutoFilter Field:=2, Criteria1:="e1_100"
   
   'Zeilen mit Werten berechnen
   If Input_WS.Sheets(1).Range("A2").End(xlDown).Row > 9999 Then
       Endzeile = 2
   Else:
       Endzeile = Input_WS.Sheets(1).Range("E2").End(xlDown).Row
   End If
       
   'Zellen kopieren
   Input_WS.Sheets(1).Range("A2:E" & Endzeile).Copy
   Output_WS.Sheets(1).Cells(Zielzeile, 1).PasteSpecial xlPasteValues
   
   Application.DisplayAlerts = False
   Input_WS.Close
   Set Input_WS = Nothing
Next i

Application.DisplayAlerts = True
End Sub

Code:

Sub DateinamenAuflisten()

Dim Dateiname As String
Dim i As Long

Dateiname = Dir$(ActiveSheet.Range("K2").Value) 'Hier Verzeichnis und Datei angeben

Do While Dateiname <> ""
   Range("G2").Activate
   ActiveCell.Offset(i, 0) = Dateiname
   i = i + 1
Dateiname = Dir$()
Loop

End Sub

Danke euch!!!

[Lutz Fricke]

Für alle zur Info:
http://www.office-loesung.de/p/viewtopic.php?f=166&t=820944

[schauan]

Hallöchen,

gehe das Kopiermakro mal mit F8 schrittweise durch und schaue insbesondere, was beim Filtern passiert...