Inhalt mit Makro kopieren
11.09.2003 09:41:02
René
ich habe folgendes Problem. Folgendes Makro öffnet alle Mappen eines Verzeichnisses und kopiert das jeweils erste Tabellenblatt hinter das erste der aktiven Mappe. Nun sollen ausgehend vom ersten Tabellenblatt alle Werte der nachfolgenden Tabellenblätter ab Zeile 6, im ersten fortlaufend gelistet werden. Dann werden alle geöffneten Mappen wieder geschlossen. Das Makro sieht für euch sicherlich wüst aus, es läuft auch nur wird aus den jeweiligen Tabellenblättern immer nur die Zeile 6 kopieret und nicht alle mit Inhalt ab Zeile 6. Ich habe aber noch nicht den nötigen durchblick und habe Versucht von einer CD Makro´s mit meinen Aufgezeichneten zu verbinden.
Danke für eure Hilfe, ich hoffe nur meine Beschreibung ist etwas verständlich geschrieben !!
MfG
René
Sub ÖffnenZusammenfassenListen()
Dim AFS As Object, i As Integer
Dim targetWB As String, sourceWB As String
Dim iCounter As Integer, iRow As Integer
Dim InI As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For InI = Worksheets.Count To 2 Step -1
Worksheets(InI).Delete
Next InI
Application.DisplayAlerts = True
Pfad = Range("V1").Value
Set AFS = Application.FileSearch
targetWB = ActiveWorkbook.Name
With AFS
ChDir Pfad
.NewSearch
.LookIn = Pfad
.Filename = "*.xls"
If .Execute > 0 Then
For i = 1 To .FoundFiles.Count
Workbooks.Open (.FoundFiles(i))
sourceWB = ActiveWorkbook.Name
Sheets(1).Copy after:=Workbooks(targetWB).Sheets(1)
Workbooks(sourceWB).Close savechanges:=False
Next
Application.ScreenUpdating = False
Sheets("Deckblatt").Select
Range("A7").Select
Rows("7:7").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("A7").Select
ActiveSheet.Unprotect
Columns("G:L").Select
Selection.EntireColumn.Hidden = False
For iCounter = ActiveSheet.Index + 1 To Worksheets.Count
iRow = Cells(Rows.Count, 6).End(xlUp).Row
iRow = iRow + 1
Cells(iRow, 1) = Worksheets(iCounter).Range("A6").Value
Cells(iRow, 2) = Worksheets(iCounter).Range("B6").Value
Cells(iRow, 3) = Worksheets(iCounter).Range("C6").Value
Cells(iRow, 4) = Worksheets(iCounter).Range("D6").Value
Cells(iRow, 5) = Worksheets(iCounter).Range("E6").Value
Cells(iRow, 6) = Worksheets(iCounter).Range("F6").Value
Cells(iRow, 13) = Worksheets(iCounter).Range("M6").Value
Cells(iRow, 14) = Worksheets(iCounter).Range("N6").Value
Columns("G:L").Select
Selection.EntireColumn.Hidden = True
Range("A7").Select
Next iCounter
Application.DisplayAlerts = False
For InI = Worksheets.Count To 2 Step -1
Worksheets(InI).Delete
Next InI
Else
MsgBox "Keine Dateien gefunden!"
End If
End With
End
Sub