AW: Inhalt von Blättern nacheiander in neuer Mappe
15.07.2011 13:23:24
Blättern
Hier der verwendete aber nicht funktionierende Code:
Option Explicit
Const HomeDatei = "C:\Makro.xls" 'Name Arbeitsmappe Makro-Excel-Datei
Const HomeDaten = "Protokoll" 'Name Tabellenblatt Daten-Import
Const HomeListe = "Protokoll" 'Name Tabellenblatt Datei-Liste
Const HomeZeile = 3 'Erste Zeile Einfügen
Const CopyZeile = 3 'Erste Zeile Kopieren
Const ListDatei = "A1" 'Zelle erster Dateiname
Const ErrMsg = "Abbruch! Datei existiert nicht: "
Sub SheetsImport()
Dim WksHome As Worksheet, WksList As Worksheet, EndLine As Integer, NextLine As Integer
Dim WkbCopy As Workbook, WksCopy As Worksheet, Fso As Object, File As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Set WksHome = Workbooks(HomeDatei).Sheets(HomeDaten)
Set WksList = Workbooks(HomeDatei).Sheets(HomeListe)
EndLine = GetEndLine(WksHome): NextLine = HomeZeile
If EndLine >= HomeZeile Then WksHome.Rows("3:" & EndLine).Cells.Clear
Application.ScreenUpdating = False
For Each File In WksList.Range(ListDatei).CurrentRegion
If Fso.FileExists(File) = False Then
Application.ScreenUpdating = True
MsgBox ErrMsg & File, vbExclamation, "Fehler": Exit Sub
End If
Set WkbCopy = Workbooks.Open(File): Set WksCopy = WkbCopy.Sheets(1)
EndLine = GetEndLine(WksCopy)
If EndLine >= CopyZeile Then
WksCopy.Rows("3:" & EndLine).Copy
WksHome.Rows(NextLine).Insert Shift:=xlDown
Application.CutCopyMode = False
WkbCopy.Saved = True: WkbCopy.Close
NextLine = GetEndLine(WksHome) + 1
End If
Next
Application.ScreenUpdating = True
End Sub