Zellen aus verschiedenen excel dateien zusammenfüg

Computer: Software & Programmierung Visual Basic
#1

hallo zusammen

gerne möchte ich aus diversen exceldateien verschiedene zellen auslesen. ich habe dies mal mit dem folgenden code funktioniert. dieser funktioniert auch, problem habe ich aber jetzt, da in den einzelnen dateien die gewünschten zellen nicht im erste sheet ist sondern in einem andern mit dem namen „verschiedeneinfos“

besten dank für eure hilfe

raphi

mein code:

Sub DatenEinlesen()
’ Daten aus mehreren Dateien in eine neue Datei einlesen
’
Dim wkbNeu As Workbook, wksDataSheet As Worksheet, Pfad As String
Dim Datei As Variant, I As Integer, J As Integer, Zellen As Variant, Titel As Variant
Pfad = „Y:\AusDateiAuslesen\Daten“ ’ Pfad der Daten-Dateien anpassen
'Spaltentitel anpassen bzw. ergänzen
Titel = Array(„Namen“, „Spezialist“, „Berater“)
'Zellen die ausgelesen werden sollen. Liste anpassen bzw. ergänzen
'Zellen in der Reihenfolge der Spaltentitel angeben
Zellen = Array(„F8“, „F26“, „F28“)
’ Neue Arbeitsmappe öffen , alternativ hier eine leere Musterdatei öffnen
Workbooks.Add Template:=„Arbeitsmappe“
Set wkbNeu = ActiveWorkbook
’ Daten-Dateien suchen
Datei = Dir(Pfad & „\eingabe*.XLS“) ’ Suchstring für EXCEL-Dateien anpasssen
’ Spaltentitel setzen, kann bei Musterdatei entfallen
For J = 0 To UBound(Titel)
wkbNeu.Sheets(1).Cells(1, J + 1) = Titel(J)
Next J
I = 2 'Startzeile für Daten in neuer Datei
Do Until Datei = „“
’ Daten-Datei öffnen
Application.ScreenUpdating = False
Workbooks.Open Pfad & „“ & Datei
Set wksDataSheet = ActiveWorkbook.Sheets(1)
’ Daten in neue Datei übertragen
For J = 0 To UBound(Zellen)
wkbNeu.Sheets(1).Cells(I, J + 1) = wksDataSheet.Range(Zellen(J))
Next J
’ Daten-Datei wieder schließen
ActiveWorkbook.Close False
Datei = Dir
I = I + 1
Application.ScreenUpdating = True
Loop
wkbNeu.Activate
’ Neue Arbeitsmappe speichern
Application.Dialogs(xlDialogSaveAs).Show
End Sub

#2

gerne möchte ich aus diversen exceldateien verschiedene zellen
auslesen. ich habe dies mal mit dem folgenden code
funktioniert. dieser funktioniert auch, problem habe ich aber
jetzt, da in den einzelnen dateien die gewünschten zellen
nicht im erste sheet ist sondern in einem andern mit dem namen
„verschiedeneinfos“

Hi Raphi,

benutze beim Code posten bitte den pre-Tag, wird unterhalb des Eingabefensters erklärt.

Nimm Screenupdating aus der Do-Loop Schleife raus und setze es davor und dahinter.

Ersetze
Set wksDataSheet = ActiveWorkbook.Sheets(1)
durch
Set wksDataSheet = ActiveWorkbook.Worksheets(„verschiedeneinfos“)

Anno74 (Alex) hat hier mal etwas zu „Dir“ geschrieben, daß man es nicht nutzen sollte. Leider habe ich den beitrag vergessen zu speichern und nicht im Archiv gefunden:frowning:

Man könnte stattdessen „Filesearch“ nehmen, das ist aber nicht zukunftsoffen da es „FileSearch“ bei XL2007 nicht mehr gibt.

Gruß
Reinhard

#3

super, besten dank reinhard

weisst du wie ich die unterordner ebenfalls noch integrieren könnte resp. die zellen auch von den files in unterordner auslesen?

danke und gruss raphi

[Bei dieser Antwort wurde das Vollzitat nachträglich automatisiert entfernt]

#4

weisst du wie ich die unterordner ebenfalls noch integrieren
könnte resp. die zellen auch von den files in unterordner
auslesen?

Hallo Raphi,

gut, man könnte da was basteln mit „dir“, aber viel einfacher ist es wenn du Filesaerch nimmst. Dabei den Befehl
.Searchsubfolders=true einbauen

Den Code zu filesearch kannst du dir leicht selbst zusammenbasteln, er steht schon weitestgehend in der Vba-Hilfe zu
Filesearch, Searchsubfolders, Execute
(Da hole ich mir auch immer den Code her)
Die Methoden wie LookIn, Filename ergeben sich ja vom namen her bzw. werden alle in der Hilfe erklärt.

Dann setzt du deinen Code der was mit der gefundenen Datei machen soll anstelle von
MsgBox .FoundFiles(i)
ein.

Bei Searchsubfolders steht z.B.

Set fs = Application.FileSearch
With fs
 .LookIn = "C:\My Documents"
 .SearchSubFolders = True
 .FileName = "cmd\*"
 If .Execute() \> 0 Then
 MsgBox "There were " & .FoundFiles.Count & \_
 " file(s) found."
 For i = 1 To .FoundFiles.Count
 MsgBox .FoundFiles(i)
 Next i
 Else
 MsgBox "There were no files found."
 End If
End With

Gruß
Reinhard

#5

[MOD] - Anmerkung: Crossposting
Crossposting in einem anderen Forum.

Gruß Rainer

#6

weisst du wie ich die unterordner ebenfalls noch integrieren
könnte resp. die zellen auch von den files in unterordner
auslesen?

Hallo Raphi, Ineressierte, Archiv,

nachstehend mein Lösungsansatz. Raphi hat den Code seit 2 tagen, da keine Rückmeldung kam nehme ich an daß der Code funktioniert.
Getestet habe ich ihn nicht. Ich habe mich mit Filesearch so rumgeprügelt, aber dazu schreibe ich gleich einen Beitrag.

Option Explicit
'
Sub DatenEinlesen()
' Daten aus mehreren Dateien in eine neue Datei einlesen
Dim wkbNeu As Workbook, wksDataSheet As Worksheet, fs As FileSearch
Dim I As Long, J As Integer, Zellen As Variant, Titel As Variant
Application.ScreenUpdating = False
'Spaltentitel anpassen bzw. ergänzen
Titel = Array("Namen", "Spezialist", "Berater")
'Zellen die ausgelesen werden sollen. Liste anpassen bzw. ergänzen
'Zellen in der Reihenfolge der Spaltentitel angeben
Zellen = Array("F8", "F26", "F28")
' Neue Arbeitsmappe öffen , alternativ hier eine leere Musterdatei öffnen
Workbooks.Add Template:="Arbeitsmappe"
Set wkbNeu = ActiveWorkbook
' Spaltentitel setzen, kann bei Musterdatei entfallen
For J = 0 To UBound(Titel)
 wkbNeu.Sheets(1).Cells(1, J + 1) = Titel(J)
Next J
' Daten-Dateien suchen
Set fs = Application.FileSearch
With fs
 .LookIn = "Y:\AusDateiAuslesen\Daten"
 .SearchSubFolders = True
 .Filename = "\*.xls"
 If .Execute() \> 0 Then
 For I = 1 To .FoundFiles.Count
 Workbooks.Open .FoundFiles(I)
 Set wksDataSheet = ActiveWorkbook.Sheets("ArbeitsblattXY1")
 ' Daten in neue Datei übertragen
 For J = 0 To UBound(Zellen)
 wkbNeu.Sheets(1).Cells(I + 1, J + 1) = wksDataSheet.Range(Zellen(J))
 Next J
 ' Daten-Datei wieder schließen
 ActiveWorkbook.Close False
 Next I
 Else
 MsgBox "There were no files found."
 End If
End With
'Datei = Dir(Pfad & "\eingabe\*.XLS") ' Suchstring für EXCEL-Dateien anpasssen
wkbNeu.Activate
' Neue Arbeitsmappe speichern
Application.ScreenUpdating = True
Application.Dialogs(xlDialogSaveAs).Show
End Sub

Gruß
Reinhard