Gruppe
Datei
Problem
Im jeweils ersten Tabellenblatt aller Arbeitsmappen in einem Ordner soll das Vorkommen des Wortes "Apfelsinensaft" gezählt und in diese Tabelle eingetragen werden.
StandardModule: basMain
Sub EintraegeZaehlen()
Dim arr As Variant
Dim iCounter As Integer, iRow As Integer
Dim sPath As String
Application.ScreenUpdating = False
Application.EnableEvents = True
On Error GoTo ERRORHANDLER
sPath = Range("B1").Value
arr = FileArray(sPath, "*.xls")
For iCounter = 1 To UBound(arr)
Workbooks.Open sPath & arr(iCounter), False
With ThisWorkbook.Worksheets("Import")
iRow = iRow + 1
.Cells(iRow, 1) = ActiveWorkbook.Name
.Cells(iRow, 2) = WorksheetFunction.CountIf(Columns(1), _
"Apfelsinensaft")
End With
ActiveWorkbook.Close savechanges:=False
Next iCounter
ERRORHANDLER:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Function FileArray(sPath As String, sPattern As String)
Dim arrFiles()
Dim iCounter As Integer
Dim sFile As String
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
sFile = Dir(sPath & sPattern)
Do While sFile <> ""
iCounter = iCounter + 1
ReDim Preserve arrFiles(1 To iCounter)
arrFiles(iCounter) = sFile
sFile = Dir()
Loop
FileArray = arrFiles
End Function