Geschlossene Dateien - Datum - Bedingung!

Eine unerschöpfliche Quelle - geschlossene Dateien auslesen. Hier eine Frage aus Office-Loesung. Aus Tabellenblatt 1 sollen 4 Werte ausgelesen werden, aus Tabellenblatt 2 Werte aus Spalten, aber nur jede zweite. Zusätzlich ist auf Tabellenblatt 2 in Zelle E3 ein Datum. Es darf erst mit dem Auslesen ab dem Datum begonnen werden. Im ersten Code wird alles ausgelesen, im zweiten Code ist die Datumsbedingung mit eingearbeitet. Bitte erst die ReadMe.txt im Download lesen!

Geschlossene Dateien - Datum - Bedingung mit Beispieldateien...[ZIP, 160 KB]

' Code gehört in Modul1

Option Explicit
' Die Tabelle wird ausgelesen
Const strSheetQ1 As String = "Tabelle1"
' Die Tabelle wird ausgelesen
Const strSheetQ2 As String = "Tabelle2"
' Die Tabelle in dieser Datei
Const strSheetZ As String = "Gesamt"
' Die Zelle wird ausgelesen
Const strCellQ1 As String = "C"
' Die Zeile in Tabelle2 wird ausgelesen
Const lngRow As Long = 10
Public Sub Files_Read()
Dim strListing As String
Dim intCalc As Integer
Dim strDir As String
Dim objFSO As Object
Dim objDir As Object
On Error GoTo Fin
With Application
.ScreenUpdating = False
.AskToUpdateLinks = False
.EnableEvents = False
intCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Mit Ordnerauswahl - dann die entsprechenden unteren
' Codezeilen auskommentieren
' If funcDirectory(strDir) <> "" Then
' Set objDir = objFSO.GetFolder(strDir)
' ThisWorkbook.Worksheets(strSheetZ).Rows _
' ("2:" & Rows.Count).ClearContents
' 'dirInfo objDir, "*.xls*", True ' Mit Unterordner
' dirInfo objDir, "*.xls*"
' End If
' Datei im gleichen Ordner wie Auswertungsdateien
'strDir = ThisWorkbook.Path
' Datei im fest vorgegebenen Ordner
strDir = "C:\Temp\Test1"
Set objDir = objFSO.GetFolder(strDir)
ThisWorkbook.Worksheets(strSheetZ).Rows _
("2:" & Rows.Count).ClearContents
'dirInfo objDir, "*.xls*", True ' Mit Unterordner
dirInfo objDir, "*.xls*"
Fin:
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = intCalc
.DisplayAlerts = True
End With
Set objDir = Nothing
Set objFSO = Nothing
End Sub
Private Sub dirInfo(ByVal objCurrentDir As Object, _
ByVal strName As String, _
Optional ByVal blnTMP As Boolean = False)
Dim objWorkbook As Workbook
Dim strFormula As String
Dim intCount As Integer
Dim strSpalte As String
Dim lngLastRow As Long
Dim intTMP As Integer
Dim varTMP As Variant
For Each varTMP In objCurrentDir.Files
If varTMP.Name Like strName And _
varTMP.Name <> ThisWorkbook.Name And _
Left(varTMP.Name, 1) <> "~" Then
With ThisWorkbook.Worksheets(strSheetZ)
lngLastRow = IIf(Len(.Cells(.Rows.Count, 2)), _
.Rows.Count, .Cells(.Rows.Count, 2) _
.End(xlUp).Row) + 1
.Cells(lngLastRow, 1).Value = varTMP.Name
' Mit Pfad
'.Cells(lngLastRow, 1).Value = varTMP.Path
For intTMP = 4 To 7
With .Cells(lngLastRow, intTMP - 2)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, _
"\") + 1) & "]" & _
strSheetQ1 & "'!" & strCellQ1 & intTMP
.Value = .Value
End With
Next intTMP
intCount = 0
For intTMP = 13 To 135 Step 2
strSpalte = Mid(.Columns(intTMP).Address, InStr _
(2, .Columns(intTMP).Address, "$") + 1)
With .Cells(lngLastRow, intCount + 6)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, _
"\") + 1) & "]" & _
strSheetQ2 & "'!" & strSpalte & lngRow
.Value = .Value
intCount = intCount + 1
End With
Next intTMP
End With
End If
Next varTMP
If blnTMP = True Then
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName, True
Next varTMP
End If
Set objWorkbook = Nothing
End Sub
Private Function funcDirectory(strDirectory As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\"
.Title = "Directory"
.ButtonName = "Select..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strDirectory = .SelectedItems(1)
If Right(strDirectory, 1) <> "\" Then _
strDirectory = strDirectory & "\"
Else
strDirectory = ""
End If
End With
funcDirectory = strDirectory
End Function


' Code gehört in Modul2

Option Explicit
' Die Tabelle wird ausgelesen
Const strSheetQ1 As String = "Tabelle1"
' Die Tabelle wird ausgelesen
Const strSheetQ2 As String = "Tabelle2"
' Die Tabelle in dieser Datei
Const strSheetZ As String = "Gesamt"
' Die Zelle wird ausgelesen
Const strCellQ1 As String = "C"
' Die Zelle mit dem Datum
Const strCellQ2 As String = "E3"
' Die Zeile in Tabelle2 wird ausgelesen
Const lngRow As Long = 10
Public Sub Files_Read_1()
Dim strListing As String
Dim intCalc As Integer
Dim strDir As String
Dim objFSO As Object
Dim objDir As Object
On Error GoTo Fin
With Application
.ScreenUpdating = False
.AskToUpdateLinks = False
.EnableEvents = False
intCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Mit Ordnerauswahl - dann die entsprechenden unteren
' Codezeilen auskommentieren
' If funcDirectory(strDir) <> "" Then
' Set objDir = objFSO.GetFolder(strDir)
' ThisWorkbook.Worksheets(strSheetZ).Rows _
' ("2:" & Rows.Count).ClearContents
' 'dirInfo objDir, "*.xls*", True ' Mit Unterordner
' dirInfo objDir, "*.xls*"
' End If
' Datei im gleichen Ordner wie Auswertungsdateien
'strDir = ThisWorkbook.Path
' Datei im fest vorgegebenen Ordner
strDir = "C:\Temp\Test1"
Set objDir = objFSO.GetFolder(strDir)
ThisWorkbook.Worksheets(strSheetZ).Rows _
("2:" & Rows.Count).ClearContents
'dirInfo objDir, "*.xls*", True ' Mit Unterordner
dirInfo objDir, "*.xls*"
Fin:
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = intCalc
.DisplayAlerts = True
End With
Set objDir = Nothing
Set objFSO = Nothing
End Sub
Private Sub dirInfo(ByVal objCurrentDir As Object, _
ByVal strName As String, _
Optional ByVal blnTMP As Boolean = False)
Dim objWorkbook As Workbook
Dim strFormula As String
Dim intCount As Integer
Dim strSpalte As String
Dim lngLastRow As Long
Dim intTMP As Integer
Dim varTMP As Variant
For Each varTMP In objCurrentDir.Files
If varTMP.Name Like strName And _
varTMP.Name <> ThisWorkbook.Name And _
Left(varTMP.Name, 1) <> "~" Then
With ThisWorkbook.Worksheets(strSheetZ)
lngLastRow = IIf(Len(.Cells(.Rows.Count, 2)), _
.Rows.Count, .Cells(.Rows.Count, 2) _
.End(xlUp).Row) + 1
.Cells(lngLastRow, 1).Value = varTMP.Name
' Mit Pfad
'.Cells(lngLastRow, 1).Value = varTMP.Path
For intTMP = 4 To 7
With .Cells(lngLastRow, intTMP - 2)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, _
"\") + 1) & "]" & _
strSheetQ1 & "'!" & strCellQ1 & intTMP
.Value = .Value
End With
Next intTMP
intCount = 0
With .Cells(1, 5)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, _
"\") + 1) & "]" & _
strSheetQ2 & "'!" & strCellQ2
.Value = .Value
.NumberFormat = "m/d/yyyy"
End With
For intTMP = 13 To 135 Step 2
strSpalte = Mid(.Columns(intTMP).Address, InStr _
(2, .Columns(intTMP).Address, "$") + 1)
With .Cells(lngLastRow, intCount + 6)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, _
"\") + 1) & "]" & _
strSheetQ2 & "'!" & strSpalte & lngRow - 7
.Value = .Value
.NumberFormat = "m/d/yyyy"
With ThisWorkbook.Worksheets(strSheetZ)
If CLng(.Cells _
(lngLastRow, intCount + 6).Value) = _
CLng(.Cells _
(1, 5).Value) Then
.Cells(1, 5).ClearContents
Exit For
End If
End With
End With
Next intTMP
For intTMP = intTMP To 135 Step 2
strSpalte = Mid(.Columns(intTMP).Address, InStr _
(2, .Columns(intTMP).Address, "$") + 1)
With .Cells(lngLastRow, intCount + 6)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, _
"\") + 1) & "]" & _
strSheetQ2 & "'!" & strSpalte & lngRow
.Value = .Value
.NumberFormat = "m/d/yyyy"
If .Cells(lngLastRow, intCount + 6) = _
.Cells(lngLastRow, intCount + 5) Then
intCount = intCount + 1
End If
End With
Next intTMP
End With
End If
Next varTMP
If blnTMP = True Then
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName, True
Next varTMP
End If
Set objWorkbook = Nothing
End Sub
Private Function funcDirectory(strDirectory As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\"
.Title = "Directory"
.ButtonName = "Select..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strDirectory = .SelectedItems(1)
If Right(strDirectory, 1) <> "\" Then _
strDirectory = strDirectory & "\"
Else
strDirectory = ""
End If
End With
funcDirectory = strDirectory
End Function

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

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