Geschlossene Dateien - UserForm - InputBox!

Es ist ein weit verbreitetes, aber auch interessantes Thema: Geschlossene Dateien auslesen. Im Folgenden mit einer UserForm bzw. einer InputBox. Hier werden die Abfragen nach Bereich, Tabelle und Unterordner geregelt.

Geschlossene Dateien - Range oder Zelle - UserForm - InputBox...[ZIP, 260 KB]

Der folgende Code gehört in "DieseArbeitsmappe":

Option Explicit
Private Sub Workbook_Deactivate()
Unload UserForm1
End Sub



Der folgende Code gehört in "UserForm1":

Option Explicit
Private Sub UserForm_Activate()
CheckBox1.Value = False
CheckBox2.Value = False
TextBox2.Text = "A1:C30"
TextBox3.Text = "Tabelle1"
Me.Tag = ""
End Sub
Private Sub TextBox1_DblClick(ByVal Cancel As _
MSForms.ReturnBoolean)
Dim strTMP As String
TextBox1.Text = funcDirectory(strTMP)
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
Private Sub CommandButton1_Click()
If CheckBox2.Value = False Then Me.Tag = "q"
Me.Hide
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, _
CloseMode As Integer)
If CloseMode = 0 Then Cancel = True
End Sub



Der folgende Code gehört in "Modul1":

Option Explicit
' Die Tabelle in DIESER Datei
Const strSheetZ As String = "Gesamt"
Dim strSheetQ As String
Dim strRange As String
Public Sub Files_Read()
Dim stCalc As Integer
Dim strDir As String
Dim objFSO As Object
Dim objDir As Object
On Error GoTo Fin
UserForm1.Show
If UserForm1.Tag = "q" Then Exit Sub
strRange = UserForm1.TextBox2.Text
strSheetQ = UserForm1.TextBox3.Text
If Trim(UserForm1.TextBox1.Text) = "" Then
strDir = ThisWorkbook.Path
Else
strDir = UserForm1.TextBox1.Text
End If
With Application
.ScreenUpdating = False
.AskToUpdateLinks = False
.EnableEvents = False
stCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objDir = objFSO.GetFolder(strDir)
If UserForm1.CheckBox1.Value = True Then
dirInfo objDir, "*.xls*", True
Else
dirInfo objDir, "*.xls*"
End If
Fin:
With Application
.Goto (ThisWorkbook.Worksheets _
(strSheetZ).Range("A1")), True
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = stCalc
.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 blnTMP As Boolean = False)
Dim objWorkbook As Workbook
Dim strFormula As String
Dim lngLastRow As Long
Dim varTMP As Variant
Dim strTMP As String
strTMP = Range(strRange).Address(RowAbsolute:=True, _
ColumnAbsolute:=True, ReferenceStyle:=xlR1C1)
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, 1)), _
.Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row) + 1
With .Range(.Cells(lngLastRow, 1), _
.Cells(Range(strRange).Rows.Count + lngLastRow - 1, _
Range(strRange).Columns.Count))
.FormulaArray = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, _
"\") + 1) & "]" & _
strSheetQ & "'!" & strRange
End With
.UsedRange.Value = .UsedRange.Value
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



Der folgende Code gehört in "Modul2":

Option Explicit
' DIE Tabelle wird ausgelesen"
Const strSheetQ As String = "Tabelle1"
' Die Tabelle in DIESER Datei
Const strSheetZ As String = "Gesamt"
Dim strRange As String
Public Sub Files_Read1()
Dim stCalc As Integer
Dim strDir As String
Dim objFSO As Object
Dim objDir As Object
On Error GoTo Fin
Select Case MsgBox("Ordner auswählen? Bei ""Nein"" wird " & _
"das Verzeichnis mit DIESER Datei genommen!", vbYesNoCancel Or _
vbQuestion Or vbDefaultButton2, "Auswahl")
Case vbYes
If Not funcDirectory(strDir) <> "" Then
MsgBox "Kein Verzeichnis ausgewählt!": Exit Sub
End If
Case vbNo
strDir = ThisWorkbook.Path
Case vbCancel
Exit Sub
End Select
strRange = InputBox("Welcher Bereich?", "Range", "A1:C30")
If Trim(strRange) = "" Then Exit Sub
With Application
.AskToUpdateLinks = False
.EnableEvents = False
stCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objDir = objFSO.GetFolder(strDir)
Select Case MsgBox("MIT UNterordner?", vbYesNo Or _
vbQuestion Or vbDefaultButton2, "Auswahl")
Case vbYes
dirInfo objDir, "*.xls*", True
Case vbNo
dirInfo objDir, "*.xls*"
End Select

Fin:
With Application
.Goto (ThisWorkbook.Worksheets _
(strSheetZ).Range("A1")), True
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = stCalc
.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 lngLastRow As Long
Dim varTMP As Variant
Dim strTMP As String
Application.ScreenUpdating = False
strTMP = Range(strRange).Address(RowAbsolute:=True, _
ColumnAbsolute:=True, ReferenceStyle:=xlR1C1)
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, 1)), _
.Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row) + 1
With .Range(.Cells(lngLastRow, 1), _
.Cells(Range(strRange).Rows.Count + lngLastRow - 1, _
Range(strRange).Columns.Count))
.FormulaArray = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, _
"\") + 1) & "]" & _
strSheetQ & "'!" & strRange
End With
.UsedRange.Value = .UsedRange.Value
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)...