Hallo Leon,
was du genau willst, geht aus deiner Spezifikation nicht so richtig hervor. Ich habe dein Makro etwas vereinfacht und Prüfroutinen für die Existenz der angesprochenen Tabellenblätter eingefügt, um auch bei wiederholter Anwendung keine Fehlermeldungen zu erhalten. Für die weiteren Tabellenblätter solltest du die Array z, qs1 und qs2 um die Tabellenblattnamen und die Nummer der Quellspalten ergänzen. Die weiteren Makros kannst du einfach durch Übergabe von Variablen steuern. Ich habe nur den Tabellenblattnamen übergeben, weitere kannst du in die Liste mit Kommata getrennt aufnehmen. Beachte, dass die Reihenfolge der Argumente, nicht deren Namen, für die Übergabe entscheidend ist.
Sub Tabellen_Einfügen()
Dim intZeile As Integer
intZeile = 7
'prüfe, ob Alles oder Tabelle1 existiert und benenne ggf. um
b = False
For Each t In Sheets
If t.Name = "Alles" Then b = True: Exit For
Next
If b = False Then
For Each t In Sheets
If t.Name = "Tabelle1" Then
b = True
t.Name = "Alles"
Exit For
End If
Next
If b = False Then MsgBox "Weder 'Tabelle1' noch Tabelle 'Alles' gefunden!"
End If
Set ta = Sheets("Alles") 'nur zur Schreibarbeitsersparnis
z = Array("Spalte1&7") 'Array der Zieltabellennamen, ggf. um weitere Namen
'für weitere Durchläufe ergänzen: Array("Spalte1&7","Spalte1&5",...)
qs1 = Array(1) 'Array für die Nummer der ersten Quellspalten, ggf. ergänzen
qs2 = Array(7) 'Array für die Nummer der zweiten Quellspalten, ggf. ergänzen
For i = 0 To UBound(z) 'durchläuft alle Zieltabellen
'Prüfung, ob eine Tabelle mit dem Namen z(i) existiert und ggf. anlegen
b = False
For Each t In Sheets
If t.Name = z(i) Then b = True: Exit For
Next
If b = False Then
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = z(i)
End If
'Kopieren
Range(ta.Cells(intZeile, qs1(i)), ta.Cells(intZeile, qs1(i)).End(xlDown)).Copy
Sheets(z(i)).Cells(intZeile - 4, 1).PasteSpecial
Range(ta.Cells(intZeile, qs2(i)), ta.Cells(intZeile, qs2(i)).End(xlDown)).Copy
Sheets(z(i)).Cells(intZeile - 4, 2).PasteSpecial
Sheets(z(i)).Columns("A:B").EntireColumn.AutoFit
Application.CutCopyMode = False
Next i
Set ta = Nothing
'weitere Makro ansprechen
Makro1 "Tabelle2"
Makro1 "Tabelle4"
Makro1 "Tabelle5"
Makro2 "Tabelle3"
Makro2 "Tabelle6"
End Sub
Sub Makro1(TabName)
b = False
For Each t In Sheets
If t.Name = TabName Then b = True: Exit For
Next
If b = True Then
Set ta = Sheets(TabName)
Else
MsgBox "Tabelle " + Chr(34) + TabName + Chr(34) + " nicht gefunden!"
End If
'deine Anweisungen, eine Zelle mit ta.Cells(Zeile,Spalte) ansprechen
Set ta = Nothing
End Sub
Sub Makro2(TabName)
'deine Anweisungen
End Sub
Gruß
Holger
Leon schrieb am 24.07.2009 10:50:14:
Hi,
habe halb mit Makro-Rekorder und halb mit einem VBA-Buch folgendes Makro erstellt:
Sub Tabellen_Einfügen()
Dim intZeile As Integer
intZeile = 7
Sheets("Tabelle1").Select
Sheets("Tabelle1").Name = "Alles"
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "Spalte1&7"
Sheets("Alles").Select
Cells(intZeile, 1).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Spalte1&7").Select
Cells(intZeile - 4, 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("Alles").Select
Cells(intZeile, 7).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Spalte1&7").Select
Cells(intZeile - 4, 2).Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveCell.Columns("A:B").EntireColumn.EntireColumn.AutoFit
‘Nächstes Tabellenblatt Spalten1, 5 und 8 usw.
End Sub
Es funktioniert auch soweit ganz gut, wird nur mit jedem neuen Tabellenblatt immer länger. (Ich habe hier nur stellvertretend das erste Tabellenblatt aufgelistet.) Da gibt es doch bestimmt eine Möglichkeit, das Ganze effektiver zu gestalten.
Anschließend sollen Tabelle 2, 4 und 5 mit einem Makro1 ausgewertet werden und Tabelle 3 und 6 mit Makro2. Diese sind schon erstellt, ich weiß nur noch nicht, wie ich sie im aktuellen Programm implementiere.
Für jede Hilfe bin ich dankbar.
Leon
|