VBA-Schleifchen einbauen :-)
14.08.2007 10:45:00
Stefan
ich habe ein Makro gefunden was meiner Anforderung recht nahe kommt. Nur leider wird in diesem makro immer nur die erste Tabelle in die Zusammenfassung mitaufgenommen. Kann mir jemand helfen dem Makro zu sagen es solle doch alle Tabellen einer Datei kopieren :-)
Ich komme ich leider an meine VBA Grenzen.
Mer ci & Gruß
Stefan
Sub auslesen()
zahl = "0"
Application.DisplayAlerts = False ' Fehlermeldungen ausschalten
'Set ziel = ActiveWorkbook
ziel = ActiveWorkbook.Name ' Zieldatei
' Alle Dateien im Quellordner suchen
Dim i As Long
' in der Zeile Quellenordner den Pfad eingeben, wo Deine Dateien liegen
' z. B. "C:\Eigene Dateien\"
Const verz = "c:\Matrix\Tableau\" ' Quellenordner
ChDir verz
With Application.FileSearch
.NewSearch
.LookIn = verz
.SearchSubFolders = True
.Filename = "*.xls"
.Execute
End With
'Mit jeder Datei ...
For i = 1 To Application.FileSearch.FoundFiles.Count
gesamt = Application.FileSearch.FoundFiles.Count
zahl = Range("A65002")
Application.StatusBar = ("Bearbeite Datensatz " & 1 + zahl & " von " & gesamt)
Set quelle = Workbooks.Open(Application.FileSearch.FoundFiles(i)) ' Öffnen
quelle = ActiveWorkbook.Name
Range("A65000") = ActiveWorkbook.Name
Range("A64999:A65000").Replace What:=".xls", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
nam = Range("A65000")
Range("A65000") = ""
Windows(ziel).Activate ' Zieldatei öffnen
Worksheets.Add.Move after:=Worksheets(Worksheets.Count) ' Neues Blatt ans Ende setzen und _
Namen vergeben
ActiveSheet.Name = nam ' Name der Quelldatei
' Daten aus Quelldatei in Zieldatei kopieren
Windows(quelle).Activate
Cells.Copy
Windows(ziel).Activate
Cells.Select
ActiveSheet.Paste
Range("A1").Select
' Neues Blatt im Inhaltsverzeichnis eintragen
Sheets("Inhaltsverzeichnis").Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
"'" & nam & "'!A1", TextToDisplay:=nam
Range("A65002") = zahl
Range("A65002") = zahl + 1
' Quelldatei schließen und keine Änderungen speichern
Windows(quelle).Close savechanges = no
Next i
Application.StatusBar = ("Bereit")
' Zieldatei speichern
Application.DisplayAlerts = True
ActiveWorkbook.Save
End Sub