Hallo,
wenn du nach deinem Abschluss in die Wissenschaft gehen möchtest, dann musst du schnell lernen, nicht so schnell zu urteilen:
"Wow das ist voll lieb, so viel mühe. Aber leider geht es nicht, der Code hat leider mehr Fehler als zuvor"
Aber ich glaube für die Praxis ist eine so forsche Art nicht schlecht ;-) . Wie viele Fehler hast du denn in dem von mir angepassten Code gefunden? Ich habe ihn gerade mal kurz getestet: ich musste ein "End Width" einfügen und dann hat er das gemacht, von dem ich so halbwegs glaube, dass du es haben möchtest.
"Meinen Code habe ich repariert aber er macht dann den kopier prozess nicht und spring zurück zu "For" "
Wenn du deine "Reparatur" posten würdest, dann könnte man dir vielleicht helfen, sie zu verbessern. So ist das eine für mich nicht hilfreiche, unnütze, in sich widersprüchliche Behauptung.
Daher hier nochmals der von mir angepasste Code, der jetzt um die Zeile "End Width" korrigiert wurde.
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(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
End With
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
Ich habe dein Konstrukt weitestgehend so belassen wie es ist (ich finde es nicht sinnvoll).
Grüße, Ulrich
|