ich habe nochmal ein kleines Problem wo ich eure Unterstützung gut gebrauchen könnte.
Ich habe hier ein Makro:
Option Explicit
Const strSheetQ As String = "THT-Handbest." ' Die Tabelle wird ausgelesen
Const strSheetZ As String = "Tabelle1" ' Die Tabelle in dieser Datei
Const strCellQ1 As String = "K38" ' Die Zelle wird ausgelesen ;F38;F40
Public Sub Files_Read()
Dim stCalc 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
stCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
Set objFSO = CreateObject("Scripting.FileSystemObject")
strDir = ThisWorkbook.Path ' Datei im gleichen Ordner wie Auswertungsdateien
Set objDir = objFSO.GetFolder(strDir)
'dirInfo objDir, "*.xl*", True ' Mit Unterordner
dirInfo objDir, "*.xl*"
Fin:
With Application
.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 strRange As String
Dim lngLastRow As Long
Dim arrCell As Variant
Dim intTMP As Integer
Dim varTMP As Variant
arrCell = Array("F38", "K38", "F40", "G42", _
"G44", "G46", "G47", "C5")
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
For intTMP = 1 To 8
strRange = arrCell(intTMP - 1)
strRange = Range(strRange).Address(RowAbsolute:=True, _
ColumnAbsolute:=True, ReferenceStyle:=xlR1C1)
.Cells(lngLastRow, intTMP).Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, _
"\") + 1) & "]" & _
strSheetQ & "'!" & strRange
Next intTMP
End With
End If
Next varTMP
If blnTMP = True Then
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName, blnTMP
Next varTMP
End If
Set objWorkbook = Nothing
End Sub
Dieses sucht in diversen Excellisten nach einem Ordner und soll aus dem Tabellenblatt "THT-Handbest." einige Zellen rausschreiben.Problem ist aktuell, wenn das gesuchte Tabellenblatt in der Exceldatei nicht vorhanden ist, dann listet er alle verfügbaren Tabellenblätter auf. Dann muss man manuell entscheiden, welches Tabellenblatt es dann sein soll.
Diesen Teil hätte ich gerne aus dem Makro rausgeschmissen.
Ist das Tabellenblatt nicht vorhanden, dann einfach mit nächster Exceldatei weiter machen.
Wer kann mir zeigen welchen Teil ich da rausschmeißen muss?
Gruß
Stefan