Auslese von Werten
16.05.2017 16:42:23
Werten
ich möchte aus mehreren Excel-Dateien ausgewählte Werte in eine Zieldatei auslesen. Das Programm arbeitet auch soweit zu meiner Zufriedenheit.
Es kann sein, dass einige Zellen in den Excel-Dateien, aus denen die Werte herausgelesen werden sollen, ohne Werte sind.
Aktuell werden die leeren Zellen in der neuen Zieldatei mit dem Wert "0" angezeigt. Jedoch sollen auch die Zellen in der Zieldatei leer sein, sowie sie es in den Quelldateien auch sind.
Hat jemand eine Idee, wie ich den Code anpassen muss?
Vielen Dank für eure Unterstützung im Voraus.
Aktueller Code:
Option Explicit
Const strSheetQ As String = "Reiter"
Const strSheetZ As String = "Ziel"
Const strCellQ1 As String = "e4"
Public Sub CommandButton1_Click()
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
'strDir = "C:\Temp\11\"
Set objDir = objFSO.GetFolder(strDir)
'dirInfo objDir, "*.xls", True
dirInfo objDir, "*.xlsx"
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 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, 1)), _
.Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row) + 1
With .Cells(lngLastRow, 1)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & _
strSheetQ & "'!" & strCellQ1
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
Next varTMP
End If
Set objWorkbook = Nothing
End Sub