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.

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

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 214786

Url: https://administrator.de/forum/dateien-im-ordner-oeffnen-x-suchen-zeile-in-blatt-kopieren-214786.html

Ausgedruckt am: 17.04.2025 um 04:04 Uhr

3 Kommentare

Neuester Kommentar

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 ?

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