VBA Zeilen aus verschiedenen Dateien kop
04.08.2020 16:15:02
Tobias
ich suche schon den Ganzen Tag nach einer Lösung, bin aber nur bedingt fündig geworden.
Ich habe einen Ordner in dem mehrere CSV-Dateien liegen. (Sie haben alle den selben Aufbau: Bezeichnung; Wert; Datum Zeit)
Ich möchte die 1. Spalte nach der Entsprechenden Bezeichnung suchen und mir dann diese Zeilen mit der entsprechendem Bezeichnung in eine Extra Tabelle kopieren.
Ich hab schon das Beispiel DatenImportieren ausprobiert das eigentlich das schon machen sollte, jedoch macht es bei CSV gar nichts. und mit den einzelnen Zeilen komme ich so auch nicht klar. Ich hab dan den Code mit dem Suchen und Zeilenrauskopieren mit eingebaut, das hat aber auch nicht funktioniert.
Ich hoffe ihr könnt mir weiterhelfen.
Anbei mal der Code. (Mit auskomentiertem zeilenrauschreiben da das auch nicht funktioniert hat)
Vielen Dank schon mal.
Sub DatenImportieren()
Dim sVerzeichnis$, sDatei$
Dim wbZiel As Workbook, wbQuelle As Workbook
Dim wksZiel As Worksheet, wksQuelle As Worksheet
Dim ZeileZ&, FileCount&
Dim Zelle As Range
Dim Anzahl As Long, A As Long
Dim Suchwert As String
'Const StartZelle$ = "G6" '1. Auszulesende Zelle in Tabelle 1
'Const Schritt& = 3 'Spaltenabstand der auszulesenden Zellen
Suchwert = InputBox("Welches Suchwort", "Suchwort eingeben") 'Suchbegriff
On Error GoTo Fehler
'Suchverzeichnis auswahlen
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Ordner mit zu durchsuchenden Dateien wählen"
.ButtonName = "Auswälen"
If .Show = -1 Then
sVerzeichnis = .SelectedItems(1)
sDatei = Dir(sVerzeichnis & Application.PathSeparator & "*.xl*")
If sDatei "" Then
'neue Datei mit einem Tabellenblatt für Ergebnisdaten erstellen
Set wbZiel = Workbooks.Add(Template:=xlWBATWorksheet)
'Zieltabellenblatt Objektvariable zuweisen
Set wksZiel = wbZiel.Worksheets(1)
ZeileZ = 1
With wksZiel
'Titelzeile ausfüllen
.Cells(ZeileZ, 1) = "Name"
.Cells(ZeileZ, 2) = "Wert"
.Cells(ZeileZ, 3) = "Datum"
End With
End If
Application.ScreenUpdating = False
Do Until sDatei = ""
FileCount = FileCount + 1
Application.StatusBar = "Datei, laufende Nr. " & FileCount & " wird bearbeitet."
'Quelldatei schreibgeschützt öffnen
Set wbQuelle = Workbooks.Open( _
Filename:=sVerzeichnis & Application.PathSeparator & sDatei, _
ReadOnly:=True)
'Tabelle1 Objektvariable zuweisen
Set wksQuelle = wbQuelle.Worksheets(1)
'Werte aus Blatt 1 auslesen
'Anzahl = Application.WorksheetFunction.CountIf(wksQuelle.Range("A1:A20"), Suchwert)
'For A = 1 To Anzahl
'If A = 1 Then
' Set Zelle = wksQuelle.Range("A:A").Find(Suchwert)
'Rows(Zelle.Row).Copy Destination:=wksZiel.Rows(A, 1) 'ganze Zeile Kopieren
'Else
' Set Zelle = wksQuelle.Range("A:A").FindNext(Zelle)
' Rows(Zelle.Row).Copy wksZiel.Cells(A, 1) 'ganze Zeile Kopieren
'End If
'Next A
Set Zelle = wksQuelle.Range(StartZelle)
Do Until IsEmpty(Zelle)
If Zelle.Value 0 Then
ZeileZ = ZeileZ + 1
With wksZiel
'Info aus Zeile 1 eintragen
.Cells(ZeileZ, 1) = wksQuelle.Cells(1, Zelle.Column).Value
'Stückzahl eintragen
.Cells(ZeileZ, 2) = Zelle.Value
'Dateiname eintragen
.Cells(ZeileZ, 3) = sDatei 'gespeicherter Dateiname
' .Cells(ZeileZ, 3) = wksQuelle.Cells(1, 1).Value 'Dateinem in A1 des Quellblatts
End With
End If
'Nächste Zelle setzen
'Set Zelle = Zelle.Offset(0,Schritt)
Loop
wbQuelle.Close savechanges:=False
Set wksQuelle = Nothing
Set wbQuelle = Nothing
sDatei = Dir
Loop
Application.ScreenUpdating = True
MsgBox "Alle Dateien ausgelesen"
End If
End With
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case Else
Application.ScreenUpdating = True
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
If Not wbQuelle Is Nothing Then wbQuelle.Close savechanges:=False
End Select
End With
Set wbZiel = Nothing
Set wbQuelle = Nothing
Application.StatusBar = False
End Sub
