Geschlossene Dateien - Anzahl Zeilen!

Frage: Wie hole ich Daten aus Spalte A aus geschlossenen Dateien, wenn mir die belegte Zeilenanzahl nicht bekannt ist? Die Spalte muss aber durchgängig gefüllt sein. So:

Geschlossene Dateien - Anzahl Zeilen...[ZIP, 200 KB]

Option Explicit
Option Private Module
'Die Tabelle wird ausgelesen
Const strSheetQ As String = "Tabelle1"
' Die Tabelle ist in der Datei mit dem Code
Const strSheetZ As String = "Sheet1"
' Diese Spalte wird ausgelesen
Const strColumn As String = "A"
' Spalte Ausgabe Dateiname
Const strFileColumn As String = "B"
Public Sub Files_Read_Range()
Dim objShell As Object
Dim varDir As Variant
Dim strDir As String
Dim objFSO As Object
Dim objDir As Object
Dim lngCalc As Long
On Error GoTo Fin
With Application
.ScreenUpdating = False
.AskToUpdateLinks = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
Set objShell = CreateObject("Shell.Application")
Set varDir = objShell.BrowseForFolder(0, "Ordner", &H4000, 17)
If varDir Is Nothing Then Set objShell = Nothing: Exit Sub
strDir = varDir.Self.Path
If strDir <> "" Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objDir = objFSO.GetFolder(strDir)
' Mit Unterordner
'dirInfo objDir, "*.xls*", True
' Mit Unterordner und Ausgebe Dateiname
dirInfo objDir, "*.xls*", True, True
' Ohne Unterordner - keine Ausgabe des Dateinamens
'dirInfo objDir, "*.xls*"
End If
Fin:
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
End With
Set objDir = Nothing
Set objFSO = Nothing
End Sub
Public Sub dirInfo(ByVal objCurrentDir As Object, _
ByVal strName As String, _
Optional ByVal blnName As Boolean = False, _
Optional ByVal blnTMP As Boolean = False)
Dim objWorkbook As Workbook
Dim strTMPFormel As String
Dim strBereich2 As String
Dim strBereich1 As String
Dim strFormula As String
Dim lngLastRow As Long
Dim varTMP As Variant
For Each varTMP In objCurrentDir.Files
If varTMP.Name Like strName And _
varTMP.Name <> ThisWorkbook.Name Then
With ThisWorkbook.Worksheets(strSheetZ)
lngLastRow = IIf(Len(.Cells(.Rows.Count, strColumn)), _
.Rows.Count, _
.Cells(.Rows.Count, strColumn).End(xlUp).Row) + 1
strBereich1 = strColumn & "1:" & strColumn & .Rows.Count
strTMPFormel = "'" & objCurrentDir & "\" & _
"[" & varTMP.Name & "]" & strSheetQ & "'!"
.Cells(1, 10).Formula = _
"=CountA(" & strTMPFormel & strBereich1 & ")"
strBereich2 = strColumn & 1 & ":" & _
strColumn & .Cells(1, 10).Value
With .Range(strColumn & lngLastRow & ":" & strColumn & _
.Cells(1, 10).Value + lngLastRow - 1)
.FormulaArray = "='" & objCurrentDir & _
"\" & "[" & varTMP.Name & "]" & _
strSheetQ & "'!" & strBereich2
.Value = .Value
End With
If blnName Then
.Cells(lngLastRow, strFileColumn).Value = varTMP.Name
' Dateiname mit Pfadangabe
'.Cells(lngLastRow, strFileColumn).Value = varTMP.Path
End If
.Cells(1, 10).Clear
End With
End If
Next
If blnTMP = True Then
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName, blnName, blnTMP
Next varTMP
End If
Set objWorkbook = Nothing
End Sub

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...