Arbeitsblätter (Tabellen)) untereinander einfügen

Sub Zwischenstand() Workbooks.Open ("D:\Test\Test1.xlsx"), UpdateLinks:=0, Password:="test", WriteResPassword:=" _ test" Worksheets("Tabelle1").Activate ActiveSheet.UsedRange.AutoFilter ActiveWorkbook.SaveAs ("D:\Test\Test2.xlsx") ActiveWorkbook.Close savechanges:=False Workbooks.Open ("D:\Test\Test2.xlsx"), UpdateLinks:=0, Password:="test", WriteResPassword:=" _ test" Worksheets("Tabelle1").Activate Range("A38:AI2000").Copy Workbooks("Zwischenstand_2015.xlsm").Worksheets("Tabelle1").Range("A4").PasteSpecial Paste:= _ xlPasteAll Application.CutCopyMode = False ActiveWorkbook.Close (False) End Sub

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Sascha,
ich hab dein Makro mal umgeschrieben/erweitert.
Der Schritt 4 ist nicht nötig.
Die letzte Zeile in den Dateien wird immer in Spalte A ermittelt, d.h. letzte Zeile mit Inhalt in Spalte A ist gleich letzte Datenzeilen in Tabellenblatt. Damit dies korrekt funktioniert müssen in Spalte A ab Zeile 38 in allen Zeilen Ingalte stehen.
Wenn dem nicht so ist, dann muss ggf. eine andere geeignete Spalte verwendet werden oder eine ander Methode zur Ermittlung der letzten Daten-Zeile.
Wenn mehrere Dateien in den Aktionen eines Makros betroffen sind, dann sollte man unbedingt mit entsprechenden Objekt-Variablen arbeiten. Es macht die Makros übersichtlicher und flexibler.
Gruß
Franz

Sub Zwischenstand()
Dim wkbZiel As Workbook, wksZiel As Worksheet
Dim intDatei As Integer
Dim wkbQuelle As Workbook, wksQuelle As Worksheet, rngCopy As Range
Dim strDatei As String, strDateiNeu As String, strPW As String, strWRP As String
Dim lngZeile_E As Long, lngZeile_L As Long, StatusCalc As Long
Dim strMsgTitel As String
strMsgTitel = "Makro: Zwischenstand"
If MsgBox("Daten nach Datei ""Zwischenstand"" importieren", _
vbQuestion + vbOKCancel, strMsgTitel) = vbCancel Then Exit Sub
'Arbeitsmappe und Tabellenblatt in das die Daten kopiert werden sollen
Set wkbZiel = ActiveWorkbook 'oder ThisWorkbook ' wenn Datei mit Makro das Ziel ist
'oder evtl. auch
'Set wkbZiel = Workbooks("Zwischenstand_2015.xlsm") 'wenn konkreter Name sein muss
Set wksZiel = wkbZiel.Worksheets("Tabelle1")
With wksZiel
'Einfügezeile für Datenblock aus 1. Datei bestimmen
'nächste freie Zeile im Zielblatt Spalte A
lngZeile_E = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
.Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count) + 1
If lngZeile_E > .Rows.Count Then
MsgBox "Blatt ist voll - Kopieren weiterer Daten nicht mehr möglich", _
vbOKOnly, strMsgTitel
GoTo Beenden
End If
End With
'Makrobremsen lösen
With Application
StatusCalc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'Dateien abarbeiten
For intDatei = 1 To 7
Select Case intDatei
Case 1
strDatei = "D:\Test\Test1.xlsx"
strDateiNeu = "D:\Test\Archiv\Test2.xlsx"
strPW = "test": strWRP = "test"
Case 2
strDatei = "D:\Test\Test1A.xlsx"
strDateiNeu = "D:\Test\Archiv\Test2A.xlsx"
strPW = "test": strWRP = "test"
Case 3
strDatei = ""
strDateiNeu = ""
strPW = "": strWRP = ""
Case Else
strDatei = ""
End Select
Application.StatusBar = _
"Aus Datei """ & intDatei & """ von 7 wird importiert: " & strDatei
If strDatei  "" Then
If Dir(strDatei) = "" Then
MsgBox "Date """ & strDatei & """ ist nicht vorhanden!", _
vbOKOnly, strMsgTitel
Else
'Quelldatei schreibgeschützt öffnen
Set wkbQuelle = Application.Workbooks.Open(Filename:=strDatei, _
ReadOnly:=True, UpdateLinks:=0, Password:=strPW, writerespassword:=strWRP)
Set wksQuelle = wkbQuelle.Worksheets("Tabelle1")
'oder auch
'      Set wksQuelle = wkbQuelle.Worksheets(1) 'wenn es immer das 1. Registerblatt ist
With wksQuelle
'Autofilter ggf. deaktivieren
If .AutoFilterMode = True Then
If .FilterMode = True Then .ShowAllData
.AutoFilterMode = False
End If
End With
'Datei unter neuem Namen speichern
Application.DisplayAlerts = False 'ggf. vorhandene Datei wird überschrieben
wkbQuelle.SaveAs Filename:=strDateiNeu, FileFormat:=51, _
Password:=strPW, writerespassword:=strWRP '51 = xlsx-Format
Application.DisplayAlerts = True
With wksQuelle
'Letzte Zeile mit Inhalt in Spalte A des Quellblattes
lngZeile_L = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
.Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
'Kopierbereich setzen (A38:AI & LngZeile_L)
Set rngCopy = .Range(.Cells(38, 1), .Cells(lngZeile_L, 35))
'Kopieren, wenn genug freie Zeilen vorhanden
If lngZeile_E + rngCopy.Rows.Count > .Rows.Count + 1 Then
MsgBox "Blatt ist voll - Nicht genug freie Zeilen zum kopieren", _
vbOKOnly, strMsgTitel
'Kopiervorgang abbrechen
Set rngCopy = Nothing
wkbQuelle.Close savechanges:=False
Set wkbQuelle = Nothing
Exit For
Else
rngCopy.Copy Destination:=wksZiel.Cells(lngZeile_E, 1)
'nächste Einfügezeile
lngZeile_E = lngZeile_E + rngCopy.Rows.Count
End If
End With
'Quelldatei ohne speichern schliessen
Set rngCopy = Nothing
wkbQuelle.Close savechanges:=False
Set wkbQuelle = Nothing
End If
End If
Next intDatei
'Makrobremsen zurücksetzen
With Application
.Calculation = StatusCalc
.ScreenUpdating = True
.EnableEvents = True
.StatusBar = False
End With
Beenden:
Set wkbZiel = Nothing: Set wksZiel = Nothing
End Sub

Beliebteste Forumthreads (12 Monate)

Arbeitsblätter (Tabellen)) untereinander einfügen

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

322 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Arbeitsblätter (Tabellen)) untereinander einfügen

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

322 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread