AW: Mit leichten Anpassungen...
05.05.2017 09:54:46
Christian
Hallo Case,
es ist schön, dass sich jemand dem Problem annimmt aber leider ist das noch nicht behoben. Hier mal der Quellcode soweit modifiziert, wie ich es konnte.
In I3 bis I100 steht die Zelle auf die in der Datenbank zugegriffen werden soll.
- Beispielsweise I3: A1558 I4: A887 I5: A455
Diesen Zellbezug soll er verwenden um die richtige Stelle in der DB zu finden und nicht die Zelle I3 an sich. (Der Inhalt ist entscheidend). Deswegen habe ich es schon mit .Value versucht, was teilweise geht.
Ziel der Abfrage für die 3 Beispiele:
Für I3: ='D:\Daten\Test\Datenbank\[#3I_D1.xlsx]#3I_D1'!A1558
Für I4: ='D:\Daten\Test\Datenbank\[#3I_H1.xlsx]#3I_H1'!A887
Für I5: ='D:\Daten\Test\Datenbank\[#3I_H4.xlsx]#3I_H4'!A455
-nach jedem Zyklus nimmt er die nächste Datei, und die nächste Zeile von I3:I100 und gibt den Wert aus Axxx entsprechend in J/K3:100 aus.
Stand mit dem Code: (Ausgabe in Spalte K und L muss weg und für J4/J5 muss I4/I5 als Wert genommen werden)
J3: ='D:\Daten\Test\Datenbank\[#3I_D1.xlsx]#3I_D1'!I3
J4: ='D:\Daten\Test\Datenbank\[#3I_H1.xlsx]#3I_H1'!I3
J5: ='D:\Daten\Test\Datenbank\[#3I_H4.xlsx]#3I_H4'!I3
K3: ='D:\Daten\Test\Datenbank\[#3I_D1.xlsx]#3I_D1'!I4
K4: ='D:\Daten\Test\Datenbank\[#3I_H1.xlsx]#3I_H1'!I4
K5: ='D:\Daten\Test\Datenbank\[#3I_H4.xlsx]#3I_H4'!I4
L3: ='D:\Daten\Test\Datenbank\[#3I_D1.xlsx]#3I_D1'!I5
L4: ='D:\Daten\Test\Datenbank\[#3I_H1.xlsx]#3I_H1'!I5
L5: ='D:\Daten\Test\Datenbank\[#3I_H4.xlsx]#3I_H4'!I5
' Variablendeklaration erforderlich
Option Explicit
' Der Tabellenblattname in den auszulesenden Dateien
Const strSheetQ As String = "Werte"
' Der Tabellenblattname in DIESER Datei (die mit dem Code)
Const strSheetZ As String = "Tabelle1"
' Module : Modul1
' Procedure : Files_Read_1
' Author : Case (Ralf Stolzenburg)
' Date : 29.10.2013
' Purpose : Geschlossene Dateien - mehrere Zellen auslesen...
Public Sub C_DB_Date5_Forum()
' Variablendeklaration
Dim blnUpdate As Boolean
Dim intCalc As Integer
Dim strDir As String
Dim objFSO As Object
Dim objDir As Object
Dim lngCalc As Long
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
On Error GoTo Fin
' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
With Application
.ScreenUpdating = False
blnUpdate = .AskToUpdateLinks
.AskToUpdateLinks = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
' Der Objektvariablen objFSO das "FilesystemObject" zuweisen
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Datei im gleichen Ordner wie Auswertungsdateien
'strDir = ThisWorkbook.Path
strDir = "D:\Daten\Test\Datenbank\" ' Fester Pfad
Set objDir = objFSO.GetFolder(strDir)
' Der Code bezieht sich auf ein bestimmtes Objekt
' Hier strSheetZ
' Alles was sich auf dieses "With" bezieht
' MUSS mit einem Punkt beginnen
With ThisWorkbook.Worksheets(strSheetZ)
' Inhalt von Tabelle "strSheetZ" wird ab Zeile 2 gelöscht
'.Rows("2:" & .Rows.Count).ClearContents
' Mit Unterordner
'dirInfo objDir, "*.xls*", True
' Ohne Unterordner
dirInfo objDir, "*.xls*"
' Formeln entfernen - Werte bleiben erhalten
'.UsedRange.Value = .UsedRange.Value
End With
Fin:
' Setze die Objektvariablen auf Nothing
Set objDir = Nothing
Set objFSO = Nothing
' Die Applikation aufwecken
With Application
.ScreenUpdating = True
.AskToUpdateLinks = blnUpdate
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
End With
' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
If Err.Number 0 Then MsgBox "Error: " & _
Err.Number & " " & Err.Description
End Sub
' Module : Modul1
' Procedure : dirInfo
' Author : Case (Ralf Stolzenburg)
' Date : 29.10.2013
' Purpose : Geschlossene Dateien - mehrere Zellen auslesen...
' Rekursive Sub mit Array - Optional mit Unterordner
Public Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
Optional ByVal blnTMP As Boolean = False)
' Variablendeklaration
Dim strFormula As String
Dim lngLastRow As Long
Dim arrCell As Variant
Dim intTMP As Integer
Dim varTMP As Variant
' Weitere Zellen nach gleichem Muster in das Array einfügen
arrCell = Array("I3", "I4", "I5")
' Alle Dateien im vorgegebenen Ordner
For Each varTMP In objCurrentDir.Files
' Dateiname entspricht den Vorgaben und ist nicht DIESE Datei
' Falls im gleichen Ordner und ist KEINE temporäre Datei
If varTMP.Name Like strName And varTMP.Name _
ThisWorkbook.Name And Left(varTMP.Name, 1) "~" Then
' Der Code bezieht sich auf ein bestimmtes Objekt
' Hier strSheetZ
' Alles was sich auf dieses "With" bezieht
' MUSS mit einem Punkt beginnen
With ThisWorkbook.Worksheets(strSheetZ)
' Letzte Zeile bezogen auf Spalte A plus 1
lngLastRow = IIf(Len(.Cells(.Rows.Count, 10)), _
.Rows.Count, .Cells(.Rows.Count, 10).End(xlUp).Row) + 1
' Schleife über alle Zellen des Arrays
For intTMP = LBound(arrCell) To UBound(arrCell)
' Hier würde jetzt noch der Dateiname mit Pfad
' in die nächste freie Spalte geschrieben
'.Cells(lngLastRow, UBound(arrCell) + 2).Value = varTMP.Path
' Hier würde jetzt noch der Dateiname
' in die nächste freie Spalte geschrieben
'.Cells(lngLastRow, UBound(arrCell) + 2).Value = varTMP.Name
' Werte über Formel holen, Tabellenblatt über "Const..."
' oben definiert, Zelle über Array. Formel in Spalte A folgende...
.Cells(lngLastRow, intTMP + 10).Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, _
"\") + 1) & "]" & strSheetQ & "'!" & arrCell(intTMP)
Next intTMP
End With
End If
Next varTMP
' Wenn die Variable blnTMP "True" ist (in der Sub "Files_Read_1" vorgegeben
' Dann durchsuche auch alle Unterordner
If blnTMP = True Then
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName, blnTMP
Next varTMP
End If
End Sub