Immer Spalte A untereinander kopieren

Forumthread: Immer Spalte A untereinander kopieren

Maris

Hallo Leutz,
ich habe hier ein Code jedoch erfüllter er nicht meine Anforderungen...
Ich habe ein Sheet in dem ich von bestimmten Tabellenblättern nicht alle... Die Spalte A von Zeile 3 bis zur letzten befüllten Zelle in eine anderes Tabellenblatt kopieren... Der Code den ich jetzt verwende ist leider nicht zu gebrauchen :-( Da mein VBA bescheiden ist hoffe ich auf Hilfe...

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

Grüßle Maris

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

AW: Immer Spalte A untereinander kopieren

26.01.2011 22:24:08

Gerold

Hallo Maris
Wie wäre es mit so etwas ?


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

Mfg Gerold
Rückmeldung wäre nett.

AW: Immer Spalte A untereinander kopieren

27.01.2011 11:28:29

Maris

Hallo Gerold,
funzt super :-D!
Danke dir!
Ich hab mal den Code wie folgt abgeändert:

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

Jetzt hab ich nicht nur das Tabellenblatt Baby & Kind... wie kann ich das auf mehrere Tabellenblätter anwenden?
Gruß,
Maris

AW: Immer Spalte A untereinander kopieren

27.01.2011 11:45:02

Maris

und ich möchte nur die Formate und WErte kopieren:

.PasteSpecial Paste:=xlValues           ' Werte
.PasteSpecial Paste:=xlFormats      ' Formate

funzt leider nicht :-(

AW: Immer Spalte A untereinander kopieren

28.01.2011 10:49:12

Gerold

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

Forumthread: Immer Spalte A untereinander kopieren

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Immer Spalte A untereinander kopieren

Forumthread: Immer Spalte A untereinander kopieren

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

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread