Immer Spalte A untereinander kopieren

Sub ColumCopy() Sheets.Add after:=Worksheets(Worksheets.Count) Sheets("Baby & Kind").Columns("A:A").Copy Sheets(Worksheets.Count).Paste Destination:=Sheets(Worksheets.Count).Columns("A:A") Application.CutCopyMode = False End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub ColumCopy() Dim Blatt As Worksheet, Zeilemax As Long, Blattda As Boolean 'Test auf Sheet "Beispiel" vorhanden Blattda = False For Each Blatt In Worksheets If Blatt.Name = "Beispiel" Then Blattda = True End If Next Blatt If Blattda = False Then 'Sheet "Beispiel" einfügen Sheets.Add after:=Worksheets(Worksheets.Count) 'Sheet in "Beispiel" umbenennen (Namen Anpassen) ActiveSheet.Name = "Beispiel" End If Sheets("Beispiel").Select 'Max Zeilenmummer ermitteln von Sheets("Tabelle1") Spalte A (Namen Anpassen) Zeilemax = Sheets("Tabelle1").Cells(Rows.Count, "A").End(xlUp).Row 'Kopieren Sheets("Tabelle1").Range("A3", "A" & Zeilemax).Copy 'Max Zeilenmummer ermitteln von Sheets("Beispiel") Spalte A (Namen Anpassen) Sheets("Beispiel").Cells(Rows.Count, "A").End(xlUp).Select If ActiveCell.Value "" Then ActiveCell.Offset(1, 0).Select 'Einfügen (Namen Anpassen) Sheets("Beispiel").Paste Application.CutCopyMode = False End Sub

Sub ColumCopy() Dim Blatt As Worksheet, Zeilemax As Long, Blattda As Boolean Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual 'Test auf Sheet "Beispiel" vorhanden Blattda = False For Each Blatt In Worksheets If Blatt.Name = "Beispiel" Then Blattda = True End If Next Blatt If Blattda = False Then 'Sheet "Beispiel" einfügen Sheets.Add after:=Worksheets(Worksheets.Count) 'Sheet in "Beispiel" umbenennen (Namen Anpassen) ActiveSheet.Name = "Beispiel" End If Sheets("Beispiel").Select 'Max Zeilenmummer ermitteln von Sheets("Tabelle1") Spalte A (Namen Anpassen) Zeilemax = Sheets("Baby & Kind").Cells(Rows.Count, "A").End(xlUp).Row 'Kopieren Sheets("Baby & Kind").Range("A3", "A" & Zeilemax).Copy 'Max Zeilenmummer ermitteln von Sheets("Beispiel") Spalte A (Namen Anpassen) Sheets("Beispiel").Cells(Rows.Count, "A").End(xlUp).Select If ActiveCell.Value "" Then ActiveCell.Offset(1, 0).Select 'Einfügen (Namen Anpassen) Sheets("Beispiel").Paste Application.CutCopyMode = False Application.ScreenUpdating = True Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic End Sub

Hallo Maris
Probiers mal hiermit.


Sub ColumCopy()
Dim Blatt As Worksheet, Zeilemax As Long, Blattda As Boolean
Dim Wks As Worksheet
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Test auf Sheet "Beispiel" vorhanden
Blattda = False
For Each Blatt In Worksheets
If Blatt.Name = "Beispiel" Then
Blattda = True
End If
Next Blatt
If Blattda = False Then
'Sheet "Beispiel" einfügen
Sheets.Add after:=Worksheets(Worksheets.Count)
'Sheet in "Beispiel" umbenennen                                     (Namen Anpassen)
ActiveSheet.Name = "Beispiel"
End If
Sheets("Beispiel").Select
'Für alle Tabellen in dieser Arbeitsmappe
For Each Wks In ThisWorkbook.Worksheets
'Für alle Tabellennamen hinter "case is ="  (Namen.... Anpassen, erweitern)
Select Case Wks.Name
Case Is = "Baby & Kind", "Tabelle1", "Tabelle3"
Zeilemax = Wks.Cells(Rows.Count, "A").End(xlUp).Row
'Kopieren
Wks.Range("A3", "A" & Zeilemax).Copy
'Max Zeilenmummer ermitteln von Sheets("Beispiel") Spalte A     (Namen Anpassen)
Sheets("Beispiel").Cells(Rows.Count, "A").End(xlUp).Select
If ActiveCell.Value  "" Then ActiveCell.Offset(1, 0).Select
'Einfügen                                                       (Namen Anpassen)
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End Select
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub

Mfg Gerold
Rückmeldung wäre nett.

Beliebteste Forumthreads (12 Monate)

Immer Spalte A untereinander kopieren

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread