AW: VBA aus N Dateien Text auslesen
09.07.2023 11:14:13
Pappawinni
Hab auch mal schnell was zusammen geschossen.
Tabellennamen musst du halt ggf. anpassen.
Ansonsten ist das ohne Schnörkel und kommentarlos, sollte aber zu deiner "Aufgabenstellung" passen.
Public Sub collectProjectData()
Dim wksTarget As Worksheet, wksSource As Worksheet
Dim colPaths As Collection
Dim i As Long
Set wksTarget = ThisWorkbook.Worksheets("Tabelle1")
wksTarget.UsedRange.Clear
If ThisWorkbook.path = "" Then
MsgBox "Store this file in the project folder" & vbCrLf & _
"before running the macro"
Exit Sub
End If
Set colPaths = findFilesInFolderByExt(ThisWorkbook.path, "xlsx")
If colPaths.Count = 0 Then
MsgBox "no item found"
Exit Sub
End If
Dim rngToCopy As Range
Dim iRow As Long, iCol As Long
Dim wbkSource As Workbook
Dim path As Variant
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
iRow = 1
iCol = 1
For Each path In colPaths
Set wbkSource = Workbooks.Open(path)
On Error Resume Next
Set rngToCopy = wbkSource.Worksheets("VZ").Range("A4:O7")
On Error GoTo 0
If Not (rngToCopy Is Nothing) Then
rngToCopy.Copy wksTarget.Range(Cells(iRow, iCol).Address)
wksTarget.Cells(iRow, iCol + rngToCopy.Columns.Count).Hyperlinks.Add _
Anchor:=wksTarget.Cells(iRow, iCol + rngToCopy.Columns.Count), _
Address:=path, TextToDisplay:=fso.getfile(path).Name
iRow = iRow + rngToCopy.Rows.Count
End If
wbkSource.Close
Next
End Sub
Private Function findFilesInFolderByExt(ByVal SourceFolderName As String, ByVal fileExtension As String, _
Optional includeSubfolders As Boolean = False) As Collection
'Liefert eine Collection mit Pfaden von Dateien der Erweiterung fileEtension ausgehend vom Pfad SourceFolderName
'für includeSubFolders = True erfolgt die Suche rekursiv, also auch in Unterordnern und deren Unterordnern,
'ausgenommen sind System und Hidden Ordner und natürlich auch Ordner für die keine Leserechte bestehen.
Dim fso As Object, SourceFolder As Object, SubFolder As Object
Dim FileItem
Dim Result As New Collection
Dim i As Long, j As Long, x
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.GetDrive(fso.GetDriveName(SourceFolderName)).path = SourceFolderName Then
Set SourceFolder = fso.GetDrive(fso.GetDriveName(SourceFolderName)).RootFolder
Else
Set SourceFolder = fso.GetFolder(SourceFolderName)
End If
'check for ReadAccess
On Error Resume Next
If Not (SourceFolder.Files.Count >= 0) Then
Exit Function
End If
On Error GoTo 0
For Each FileItem In SourceFolder.Files
If LCase(fso.GetExtensionName(FileItem.path)) = LCase(fileExtension) Then
Result.Add FileItem.path
End If
Next FileItem
DoEvents
If includeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
If Not ((SubFolder.Attributes And (vbSystem Or vbHidden)) > 0) Then
Dim SubResult As Collection
Set SubResult = findFilesInFolderByExt(SubFolder.path, fileExtension, True)
If SubResult.Count > 0 Then
For Each x In SubResult
Result.Add x
Next
End If
Set SubResult = Nothing
End If
Next SubFolder
End If
Set findFilesInFolderByExt = Result
End Function