Excel Dateien durchsuchen und Teile extrahieren

On Error Resume Next
Const FOLDER = "D:\Sheets"  
Set fso = CreateObject("Scripting.FileSystemObject")  
Set objExcel = CreateObject("Excel.Application")  
With objExcel
    .Visible = False
    .DisplayAlerts = False
    .ScreenUpdating = False
End With

For Each file In fso.GetFolder(FOLDER).Files
    If LCase(fso.GetExtensionName(file.Name)) = "xlsx" Then  
        With objExcel.Workbooks.Open(file.Path).Sheets.Item(1)
            For Each cell In .Range("A1:A" & .Cells.Item(.Rows.Count,"A").End(-4162).Row)  
                If cell.Value <> "" Then  
                    arrData = Split(cell.Value,",",-1,1)  
                    If UBound(arrData) >= 2 Then
                        cell.Value = Join(Array(arrData(0),arrData(1),arrData(2)),",")  
                    End If
                End If
            Next
            .Parent.Save
            .Parent.Close
        End With
    End If
Next
With objExcel
    .DisplayAlerts = True
    .ScreenUpdating = True
    .Quit
End With
Set fso = Nothing
Set objExcel = Nothing
MsgBox "Habe fertig",vbInformation  

On Error Resume Next
Const FOLDER = "D:\Daten"  
Const ABSTRACT = "D:\Daten\out\zusammenfassung.xlsx"  

Set fso = CreateObject("Scripting.FileSystemObject")  
Set objExcel = CreateObject("Excel.Application")  
Set dic = CreateObject("scripting.dictionary")  

With objExcel
	.Visible = False
	.DisplayAlerts = False
	.ScreenUpdating = False
End With

For Each file In fso.GetFolder(FOLDER).Files
	If LCase(fso.GetExtensionName(file.Name)) = "xlsx" Then  
		With objExcel.Workbooks.Open(file.Path).Sheets.Item(1)
			For Each cell In .Range("A1:A" & .Cells.Item(.Rows.Count,"A").End(-4162).Row)  
				If cell.Value <> "" Then  
					arrData = Split(cell.Value,",",-1,1)  
					If UBound(arrData) >= 2 Then
						cell.Value = Join(Array(arrData(0),arrData(1),arrData(2)),",")  
						If dic.Exists(arrData(2)) Then
							dic.Item(arrData(2)) = dic.Item(arrData(2)) + 1
						Else
							dic.Add arrData(2),1
						End If
					End If
				End If
			Next
			.Parent.Save
			.Parent.Close
		End With
	End If
Next
keys = dic.Keys
If Not fso.FolderExists(fso.GetParentFolderName(ABSTRACT)) Then fso.CreateFolder fso.GetParentFolderName(ABSTRACT)
With objExcel.Workbooks.Add.Sheets(1)
	For i = 0 To UBound(keys)
		.Cells.Item(i+1,1).Value = keys(i)
		If dic.Item(keys(i)) > 1 Then .Cells.Item(i+1,2).Value = dic.Item(keys(i))
	Next
	.Parent.SaveAs ABSTRACT
	.Parent.Close
End With

With objExcel
	.DisplayAlerts = True
	.ScreenUpdating = True
	.Quit
End With
Set fso = Nothing
Set objExcel = Nothing
MsgBox "Habe fertig." & vbNewline & "Die Zusammenfassung finden sie unter '" & ABSTRACT &  "'.",vbInformation  

.Range("A:B").Sort .Range("A1"),1,,,,,,0