AW: suchen von inhalten in dateien
10.05.2005 23:07:59
inhalten
Hallo
Hier mal eine Basis um einen bestimmten Bereich auszulesen.
Bei deinem Level kannst du das ja sicher anpassen.
Die Daten werden in diesem Beispiel nicht in eine MsgBox geschrieben, sondern in die aktuelle Tabelle
Sub Read_All_Datas_from_defined_Workbooks_without_Opening()
'by Ramses
'Liest alle Daten aus geschlossenen Arbeitsblättern
'aus einem bestimmten Bereich ein.
'Alle eingelesenen Daten werden untereinander aufgelistet.
'Die Daten werden in Dateien mit dem Datei-Teilbegriff "Report"
'gesucht und eingelesen
Dim i As Long, totFiles As Long
Dim ColCounter As Integer, rowCounter As Long
Dim n As Integer, k As Integer
Dim gefFile As String, TeilName As String
Dim Suchpfad As String, Suchbegriff As String, Dateiform As String
Dim tmpPfad As String, tmpName As String, tmpFile As String
Dim curWB As Workbook, tarwks As Worksheet, datWKS As String
Dim oldStatus As Variant
Dim myR1 As String, myR2 As String, myR3 As String
Suchpfad = InputBox("Geben Sie den Ordner an, der durchsucht werden soll.", "Pfad definieren", "D:") 'Application.DefaultFilePath)
If Suchpfad = "" Then Exit Sub
Dateiform = InputBox("Geben Sie den Dateityp an der gesucht werden soll", "Dateierweiterung", "*.xls")
If Dateiform = "" Then Exit Sub
Application.ScreenUpdating = True 'zur definitiven Ausführung auf False setzen
oldStatus = Application.StatusBar
'ZählVariablen setzen
rowCounter = 1
ColCounter = 2
'Variablen für aktive Mappe setzen
Set curWB = Workbooks(ThisWorkbook.name)
Set tarwks = curWB.Worksheets("Tabelle1")
'zu kopierende Bereiche definieren
'Variablen für den DateiNamen der entsprechenden Tabelle ersezten
TeilName = "Report"
'Tabellenname in der Mappe mit dem Teilstring "TeilName"
datWKS = "Summary"
'zu lesende Bereich definieren
myR1 = datWKS & "'!R3C2"
myR2 = datWKS & "'!R17C4"
'Datumsformat in Spalte D zuweisen
Columns(4).NumberFormat = "m/d/yyyy"
'Dateisuche starten
With Application.FileSearch
.LookIn = Suchpfad
.SearchSubFolders = False
.FileName = Dateiform
'Wenn gefunden,..
'Schleifenauswertung beginnen
If .Execute() > 0 Then
totFiles = .FoundFiles.count
Application.StatusBar = "Total " & totFiles & " gefunden"
For i = 1 To .FoundFiles.count
gefFile = .FoundFiles(i)
'Namen und String zusammensetzen
tmpName = Right(gefFile, Len(gefFile) - InStrRev(gefFile, "\", -1))
tmpPfad = Left(gefFile, Len(gefFile) - Len(tmpName))
tmpFile = "'" & tmpPfad & "[" & tmpName & "]"
'Die Formel für das Excel4-Macro muss im R1C1 - Format erstellt werden
'Auch die Rechteckklammern müssen eingebaut werden
'Hochkomma's nicht vergessen !!
''D:\[Muster.xls]Summary'!R3C2
If UCase(Left(Right(gefFile, Len(gefFile) - 3), Len(TeilName))) = UCase(TeilName) Then
'In Tabelle eintragen
tarwks.Cells(rowCounter, 1) = Application.ExecuteExcel4Macro(tmpFile & myR1)
tarwks.Cells(rowCounter, 2) = Application.ExecuteExcel4Macro(tmpFile & myR2)
tarwks.Cells(rowCounter, 2).NumberFormat = "0.00%"
'Zwei neue Schleifen um die einzelnen zellen in
'den Zieldateien auszulesen
'Datenbereich von B23 : F39 einlesen
For k = 23 To 39
For n = ColCounter To 6
myR3 = datWKS & "'!R" & k & "C" & n & ":R" & k & "C" & n
tarwks.Cells(rowCounter, n + 1) = Application.ExecuteExcel4Macro(tmpFile & myR3)
Next n
rowCounter = rowCounter + 1
Next k
rowCounter = rowCounter + 1
End If
Next i
End If
End With
Application.StatusBar = oldStatus
Application.ScreenUpdating = True
End Sub
Gruss Rainer