3
Dateien im Ordner öffnen, x suchen, Zeile in Blatt kopieren
Hallo Zusammen, habe versucht dieses Script ein wenig anzupassen. Leider scheinen meine Vba Kenntnisse noch nicht ganz auszureichen.
('bis hier hin ok) läuft der Code richtig durch wenn die End if und Next richtig gesetzt wären. Diese sind durch viel hin und her versuchen auch durcheinander geraden.
Wäre toll wenn ihr mir helfen könnt.
('bis hier hin ok) läuft der Code richtig durch wenn die End if und Next richtig gesetzt wären. Diese sind durch viel hin und her versuchen auch durcheinander geraden.
Wäre toll wenn ihr mir helfen könnt.
Sub Zusammenfassen2()
Dim i As Long
'' Testpath
Const sSourcePath = "c:\test\" 'Ordner der Auswertedateien - bitte anpassen
Set wbGes = ActiveWorkbook 'aktuelle Mappe und ...
Set wsZiel = ActiveWorkbook.ActiveSheet '... aktuelle Tabelle zwischenspeichern
Set fso = CreateObject("Scripting.FileSystemObject")
Z = 2 'ab Zeile 2 in der Sammeltabelle eintragen
sNamen = "#" 'Variable zum Sammeln der Namen vorbelegen
Application.ScreenUpdating = False 'während der folgenden Aktionen Excel-Bildschirm "einfrieren"; diese Zeile kann auch auskommentiert / entfernt werden
For Each oFile In fso.GetFolder(sSourcePath).Files 'alle Dateien des Auswerteordners durchgehen
If LCase(fso.GetExtensionName(oFile.Name)) = "xls" Then 'nur .xls-Dateien bearbeiten; falls "xlsx" bitte anpassen; nur Kleinbuchstaben verwenden
Set wbQuellDatei = Application.Workbooks.Open(oFile.Path) 'Auswerttedatei öffnen
With ActiveWorkbook.Worksheets(1) 'Daten aus der ersten Tabelle der Auswertedatei entnehmen
ZielZeile = Cells(Rows.Count, 1).End(xlUp).Row 'letzte Zeile ermitteln
For i = 9 To ZielZeile ' Bereich von 9 bis letzte Zeile
If .Cells(i, 15) = "X" Then ' Wenn O zeile = x dann
MsgBox " Gefunden" ' nur als test hier !!!
Wert = Rows(i).Copy ' bis hier hin OK
wsZiel.Cells(Z, i).Paste '... einfügen ( falscher Befehl für eine Row ? )
End If 'falsch platziert?
Next ' falsch plaziert ?
Z = Z + 1 'Zeilennummer der Zieltabelle für das nächste Einfügen erhöhen
End If #ggf. 'auch falsch platziert ?
Next ' falsch platziert ?
wbQuellDatei.Close 'Datei schließen
End With
Application.ScreenUpdating = True 'Excel-Bildschirmanzeige wieder "auftauen" ;-)
wsZiel.Activate 'zur Sicherheit Zieltabelle aktivieren
wbGes.Save 'Sammeldatei speichern
MsgBox "Fertig."
End If
End Sub
Share on Facebook
Share on Twitter
Share on Reddit
Share on LinkedinPlease also mark the comments that contributed to the solution of the article
Content-Key: 214786
Url: https://administrator.de/contentid/214786
Printed on: April 20, 2024 at 01:04 o'clock
3 Comments
Latest comment
Hallo Firewalker!
End With sollte nicht in Zeile 38, sondern in Zeile 30 stehen - wenn Du konsequent alle Blöcke (hier: For, If und With) einrückst, ist das leichter zu erkennen ...
Hallo bastla.
Ok habe es so verschoben und Zeile 44 Enf if raus genommen. Jetzt läuft das Script schon mal wieder an.
Jetzt kommt der Fehler in Zeile 25. sobald ein X gefunden wurde.
Was soll er tun: Bein finden von X in Spalte O die gesammte Zeile kopieren ( alternativ wäre auch a-o möglich) und in wsZiel kopieren. Liegt es dort am i ?
Und warum ist Wert definert, den rufe ich doch gar nicht wieder auf ?
Ok habe es so verschoben und Zeile 44 Enf if raus genommen. Jetzt läuft das Script schon mal wieder an.
Jetzt kommt der Fehler in Zeile 25. sobald ein X gefunden wurde.
Was soll er tun: Bein finden von X in Spalte O die gesammte Zeile kopieren ( alternativ wäre auch a-o möglich) und in wsZiel kopieren. Liegt es dort am i ?
Und warum ist Wert definert, den rufe ich doch gar nicht wieder auf ?
Habe es glaube ich hinbekommen.
Sub Zusammenfassen2()
ActiveWorkbook.Worksheets(1).Range("A2:O30000").ClearContents
Dim i As Long
'' Testpath
Const sSourcePath = "c:\test\" 'Ordner der Auaswertedateien - bitte anpassen
Set wbGes = ActiveWorkbook 'aktuelle Mappe und ...
Set wsziel = ActiveWorkbook.ActiveSheet '... aktuelle Tabelle zwischenspeichern
Set fso = CreateObject("Scripting.FileSystemObject")
Z = 2 'ab Zeile 2 in der Sammeltabelle eintragen
sNamen = "#" 'Variable zum Sammeln der Namen vorbelegen
Application.ScreenUpdating = False 'während der folgenden Aktionen Excel-Bildschirm "einfrieren"; diese Zeile kann auch auskommentiert / entfernt werden
For Each oFile In fso.GetFolder(sSourcePath).Files 'alle Dateien des Auswerteordners durchgehen
If LCase(fso.GetExtensionName(oFile.Name)) = "xls" Then 'nur .xls-Dateien bearbeiten; falls "xlsx" bitte anpassen; nur Kleinbuchstaben verwenden
Set wbQuellDatei = Application.Workbooks.Open(oFile.Path) 'Auswerttedatei öffnen
With ActiveWorkbook.Worksheets(1) 'Daten aus der ersten Tabelle der Auswertedatei entnehmen
ZielZeile = Cells(Rows.Count, 1).End(xlUp).Row 'letzte Zeile ermitteln
For i = 9 To ZielZeile ' Bereich von 9 bis letzte Zeile
If .Cells(i, 15) = "X" Then ' Wenn O zeile = x dann
wert = Rows(i).Copy ' bis hier hin OK
wsziel.Rows(Z).PasteSpecial '... einfügen
Z = Z + 1 'Zeilennummer der Zieltabelle für das nächste Einfügen erhöhen
End If
Next
End With
End If
Next
wbQuellDatei.Close 'Datei schließen
Application.ScreenUpdating = True 'Excel-Bildschirmanzeige wieder "auftauen" ;-)
wsziel.Activate 'zur Sicherheit Zieltabelle aktivieren
wbGes.Save 'Sammeldatei speichern
MsgBox "Fertig."
End Sub
