Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1416to1420
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Arbeitsblätter (Tabellen)) untereinander einfügen

Arbeitsblätter (Tabellen)) untereinander einfügen
31.03.2015 12:47:13
Sascha
Hallo allerseits,
gleich vorneweg:
ich habe bereits in einem anderen Forum um Hilfe gebeten und mir wurde auch geholfen. Allerdings konnte ich diese Hilfe nicht umsetzen und habe auf die erneute Anfrage keine Rückmeldung bekommen.
Es geht um folgendes:
Ich habe bereits ein Makro gebastelt das folgendes macht:
1. Öffnen einer Datei
2. Alle Filter entfernen
3. Speichern unter einem anderen Namen und in einem anderen Verzeichnis
4. Danach wieder öffnen dieser Datei und dann die Werte aus dem ersten Reiter (Range A38:AI2000)
5. In die Datei einspielen , aus dem der Makro gestartet wird (Reiter Range A4)
Hier das Makro:
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

Funktioniert soweit auch alles, bloß jetzt habe ich noch ein Problem :
Ich muss auch noch 6 andere Tabellen aus 6 anderen Arbeitsmappen einspielen.
Am Ende sollen alle 7 Tabellen untereinander sein.
Problem ist, dass die Länge der Tabelle variieren kann. Theoretisch kann ich natürlich den bereits erstellten Makro 7 mal hintereinander laufen lassen , aber dann kann es ja sein , dass ich durch das reinkopieren Datensätze aus den anderen Tabellen weglösche.
Der Range A38:AI2000 kann beim nächsten mal auch nur bis A38:AI1500 gehen und danach wieder länger oder so.
Als Hilfe bekam dann ich folgende Info, die ich auch 1:1
Bereich dynamisch erstellen->
Letzte Zeile suchen mit:
Code:
loEnd = IIf(IsEmpty(.Cells(.Rows.Count, "A")), .Cells(.Rows.Count, 2).End(xlUp).Row, .Rows.Count)Dann Kopierbereich wie folgt definieren:
Code:
Range("A38:AI" & loEnd).CopyEinfügeposition wie folgt definieren:
Code:
Workbooks("Zwischenstand_2015.xlsm").Worksheets("Tabelle1").Range("A" & loEnd).PasteSpecial Paste:=xlPasteAll
Wenn man die 3 Zeilen so anpasst, kommt immer die Nachricht "Fehler beim kompilieren".
Könnt ihr mir vielleicht weiterhelfen? Ich bin leider mit den Variablen da noch nicht so vertraut und habe wirklich nur die Basiskenntnisse der Basiskenntnisse von VBA.
Vielen Dank im Voraus erstmal.
Gruß
Sascha

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Arbeitsblätter (Tabellen)) untereinander einfügen
01.04.2015 12:30:04
fcs
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

Anzeige

322 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige