Hallo,
mir scheint, als ob du hier zwei Codeschnipsel aneinander gefügt hast, die nichts miteinander zu tun haben (sollten).
Es ist auch stark davon abhängig, was du in die Inputbox eingibst. Ich gehe mal vom Default aus, also
*.xls*
. Mir steht gerade kein Excel zur Verfügung, doch ich versuche es trotzdem einmal:
Hiermit
sn = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & f & ibox & """ /s /a /b").stdout.readall, vbCrLf)
Sheets(1).Cells(1).Resize(UBound(sn) + 1) = Application.Transpose(sn)
werden Dateinamen inklusive Pfad in die erste Spallte eingetragen, z.B. "c:\test\test\Datei.xlsx"
Nun folgt
strPath = ThisWorkbook.Worksheets(1).Cells(i, 1) ' <--Enter Path here
strExt = "*.xlsx" ' <-- Enter Data Type you want to open
die Variable strPath hat also jetzt den Inhalt "c:\test\test\Datei.xlsx". Es folgt der Aufruf
strFile = Dir(strPath & strExt)
dabei ergibt strPath & strExt "c:\test\test\Datei.xlsx*.xlsx". Diese Datei existiert nicht, daher gibt Dir("c:\test\test\Datei.xlsx*.xlsx") einen leeren String zurück.
Und das funktioniert nunmal nicht. Daher mein ungetesteter Vorschlag:
Sub Mehrere_Dateien_einlesen()
Dim strFile As String
Dim i As Long
Dim fldr As FileDialog
'Opens All Subfolders and lists them in the Activeworksheet
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
fldr.Show
f = fldr.SelectedItems(1)
f = f & "\"
ibox = "*.xls*" 'InputBox("File Must Contain (Note * wildcards can be used) ", , "*.xls*")
On Error resume next
sn = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & f & ibox & """ /s /a /b").stdout.readall, vbCrLf)
' Sheets(1).Cells(1).Resize(UBound(sn) + 1) = Application.Transpose(sn) 'write Path- and Filenames to worksheet
on error goto 0
For i = 0 To ubound(sn)-1 'Schleife über alle Dateinamen in sn
strFile = sn(i) 'Dateiname
with Workbooks.Open(Filename:=strFile) ' Opens File
If BlattExist(.sheets(1).parent, "Beutel(bag)") Then ' <-- Enter the Worksheet that includes the Data
.Worksheets("Beutel(bag)").Range("B73,F73:I73,B90,F90:I90,B91,F91:I91").Copy '<-- Enter Cells that include the Data
sBlattName = left(dir(strFile), 31) 'Sheetname = Filename (if Name exceeds 31 Characters, it will be shortened)
MsgBox "Found Data copying will be done"
ThisWorkbook.Worksheets.Add().Name = sBlattName
' ThisWorkbook.Worksheets.Add.Name = sBlattName <= ich glaube, dass dies falsch ist, evtl. diese statt vorheriger Zeile benutzen
ThisWorkbook.Worksheets(sBlattName).Range("A1").PasteSpecial Paste:=xlValues
Application.CutCopyMode = False 'deletes the copy buffer
Else
MsgBox "File doesnt include Worksheet ""Beutel(bag)"""
End If
.close False 'Datei schließen
next
End Sub
'Function of checking the existance of a Worksheet
Function BlattExist(wb as workbook, strBlatt As String) As Boolean
Dim shDummy
On Error Resume Next: Err.Clear
Set shDummy = wb.Sheets(strBlatt)
If Err.Number = 0 Then
BlattExist = True
End If
End Function
wie gesagt: ungetestet! Funktioniert es?
Grüße, Ulrich
|