VBA Kopieren Tabellenkalkulation

Question

Hallo Leute,

kann mir jemand hierbei bitte helfen.
Das ist mein Makro, die läuft soweit so gut. Über einen Botton in meiner Exceltabelle bringe ich die Marko zum laufen. Nun möchte ich wenn ich den Botton betätige das mein Marko folgendes tut:

1.entweder alle bestehen Zelleninhalte löscht und dann einfach alle neu hinein kopiert plus dem neuen Tabellenblatt
oder
2. um ein neues Tabellenblatt erweitert.

Momentan führt das Makro folgendes aus, nach dem ich den Bottum betätig habe kopiert er alle bestehenden Tabellenblätter mit dem Namen ABT und zusätzlich das neue Tabellenblatt.
Beispiel: Ich habe 5 Tabellenblätter, alle Tabellenblätter heissen ABT 1; ABT2; ABT3 usw.
Diese sind bereits per Marko im Tabellenblatt Archiv abgespeichert. Nun kommt ein 6 Tabellenbalt dazu Namens ABT 6. Betätige ich jetzt den Bottom dann werden alle 5 Tabellenblätter erneut kopiert und zustätlich das neue 6 Tabellenblatt. Wenn jedes Tabellenblatt jeweils 10 Einträge besitzt, dann sollte im Tabellenblatt Archiv normalerweise 50 Zellen + 10 neue Einträge sein.
Die Realität sieht aber so aus... 110 Zelleneinträge. Also die 50 bereitsvorhandenen +50 erneut die gleichen Einträge +die 10 neuen.

Hier ist die Makro:

Sub DATENBANK1SAFinale()
Dim ws As Worksheet

Application.ScreenUpdating = False

Bereich = "A1:X" & Cells(Rows.Count, 1).End(xlUp).Row
Set Quelltab = ActiveWorkbook.Worksheets("Archiv")
Quelltab.Range(Bereich).ClearContents

For Each ws In ActiveWorkbook.Worksheets


If Left(ws.Name, 3) = "ABT" Then

With Worksheets(ws.Name)
.Range("A1:X" & .Cells(Rows.Count, 1).End(xlUp).Row).Copy
End With

With Worksheets("Archiv")
.Range("A" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With

End If

Next ws

Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Answer 1

Hallo Florian,

von welcher Tabelle ermittest du die letzte Zeile?
Deshalb würde ich das Makro so schreiben:

Sub DATENBANK1SAFinale()
Dim ws As Worksheet

Application.ScreenUpdating = False

Set Quelltab = ActiveWorkbook.Worksheets("Archiv")
Bereich = "A1:X" & Quelltab.Cells(Rows.Count, 1).End(xlUp).Row

Quelltab.Range(Bereich).ClearContents

For Each ws In ActiveWorkbook.Worksheets
If Left(ws.Name, 3) = "ABT" Then

With Worksheets(ws.Name)
.Range("A1:X" & .Cells(Rows.Count, 1).End(xlUp).Row).Copy
End With

With Worksheets("Archiv")
.Range("A" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With

End If

Next ws

Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Gruß

M.O.

Answer 2

Hallo Mo,

vielen Dank für deine Anwort erstmal.
Das hat soweit gut geklappt.
Hättest du für diese Makro vielleicht auch noch mal einen guten tipp.
Problem bei dieser Makro ist das es einfach viel zu lange dauert bis alles ausführt ist.
Eben so habe ich für das Tabellenblatt names Output keine verwendung mehr.

Mit dieser Makro erstelle ich eine neues Tabellenblatt welches ich beliebig bennen kann und welches die Exceldaten aus einem von mir angelegten Ordner heraus kopiert und diese in das neue Tabellenblatt hineinkopiert.


Sub DATENBANK()
Dim strName As String
Dim wb1 As Workbook

Set wb1 = ActiveWorkbook
Sheets.Add After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
neuname = InputBox("New Data")
ActiveSheet.Name = neuname

Dim Quelltab As Worksheet
Dim Zieltab As Worksheet
Dim Zelle As Range
Dim Zaehler As Long

Zaehler = 1
Bereich = "A1:A" & Cells(Rows.Count, 1).End(xlUp).Row

Set Quelltab = ActiveWorkbook.Worksheets("Source")
Set Zieltab = ActiveWorkbook.Worksheets("Output")

Quelltab.Range(Bereich).ClearContents

again:
ABT = InputBox("Type in the Modelname")

On Error GoTo again
Workbooks.Open Filename:="C:\Users\Documents\" & ABT & ".xls"


Workbooks(ABT & ".xls").Activate
Worksheets("New Tools").Select
lz = Worksheets("New Tools").Cells(Rows.Count, 2).End(xlUp).Row
Workbooks(ABT & ".xls").Worksheets("New Tools").Range("A1:X" & lz).Copy Destination:=wb1.Worksheets(neuname).Range("A1")
Workbooks(ABT & ".xls").Close savechanges = False

For Each Zelle In Quelltab.Range("A1:A500")
Zieltab.Cells(Zaehler, 1) = Zelle
Zaehler = Zaehler + 1

Next Zelle
End Sub


Gruß Florian

Answer 3

Hallo Florian,

schau mal, ob ich dich so richtig verstanden habe:

Sub DATENBANK()
Dim neuname As String
Dim ABT As String
Dim wb1 As Workbook
Dim lz As Long
Dim anw
Dim i As Long

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

Set wb1 = ActiveWorkbook

inputname:
neuname = InputBox("New Data")

If neuname = "" Then
anw = MsgBox("Invalid name! Try again?", 20, "Error")
If anw = vbYes Then
GoTo inputname
Else
Exit Sub
End If
End If

For i = 1 To wb1.Worksheets.Count
If neuname = Worksheets(i).Name Then
anw = MsgBox("The name " & neuname & " already exists in this workbook! Try again?", 20, "Error")
If anw = vbYes Then
GoTo inputname
Else
Exit Sub
End If
End If
Next i

again:
ABT = InputBox("Type in the Modelname")
If ABT = "" Then
anw = MsgBox("Invalid name! Try again?", 20, "Error")
If anw = vbYes Then
GoTo again
Else
Exit Sub
End If
End If

If Dir("C:\Users\Documents\" & ABT & ".xls") = "" Then
anw = MsgBox("The file " & ABT & ".xls doesn't exist! Try again?", 20, "Error")
If anw = vbYes Then
GoTo again
Else
Exit Sub
End If
End If

Sheets.Add After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
ActiveSheet.Name = neuname

Workbooks.Open Filename:="C:\Users\Documents\" & ABT & ".xls"

With Workbooks(ABT & ".xls")
lz = .Worksheets("New Tools").Cells(Rows.Count, 2).End(xlUp).Row
.Worksheets("New Tools").Range("A1:X" & lz).Copy Destination:=wb1.Worksheets(neuname).Range("A1")
.Close (False)
End With

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Gruß

M.O.

Answer 4

Hallo Mo,

vielen Dank ...all deine Tipps haben mir gut geholfen.
Nun habe ich nochmal eine Frage.
Ich bräuchte hilfe um eine Makro zu schreiben die folgendes tuen soll.

Nachdem ich diese Makro aktiviert habe....

Sub DATENBANK()
Dim strName As String
Dim wb1 As Workbook

Set wb1 = ActiveWorkbook
Sheets.Add After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
neuname = InputBox("New Data")
ActiveSheet.Name = neuname

Dim Quelltab As Worksheet
Dim Zieltab As Worksheet
Dim Zelle As Range
Dim Zaehler As Long

Zaehler = 1
Bereich = "A1:A" & Cells(Rows.Count, 1).End(xlUp).Row

Set Quelltab = ActiveWorkbook.Worksheets("Source")
Set Zieltab = ActiveWorkbook.Worksheets("Source")

Quelltab.Range(Bereich).ClearContents

again:
ABT = InputBox("Type in the Modelname")

On Error GoTo again
Workbooks.Open Filename:="C:\Users\Documents\" & ABT & ".xls"


Workbooks(ABT & ".xls").Activate
Worksheets("New Tools").Select
lz = Worksheets("New Tools").Cells(Rows.Count, 2).End(xlUp).Row
Workbooks(ABT & ".xls").Worksheets("New Tools").Range("A1:X" & lz).Copy Destination:=wb1.Worksheets(neuname).Range("A1")
Workbooks(ABT & ".xls").Close savechanges = False

For Each Zelle In Quelltab.Range("A1:A500")
Zieltab.Cells(Zaehler, 1) = Zelle
Zaehler = Zaehler + 1

Next Zelle
End Sub


brauche ich eine zweite Marko die aus dem Tabellenblatt Source in das Tabellenblatt Ausgabe
in die Spalte A1 bis A10 die Artikelnummern die immer von der Anzahl varrieren können hinein kopiert, mal sind es 70 stück mal 150 mal 200 mal 100 stück etc.

So sollte es sein: Zum beispiel bekomme ich morgen 150 neue Artikelnummern, dann sollen nicht alle 150 Nummern in das Tabellenblatt Ausgabe hinein kopiert werden sondern immer in 10ner schritten nur 10 Nummern. Und das immer wenn ich die Makro per buttom klick betätige.
Beim ersten Klick werden von den 150 Artikelnummern die ersten 10 Kopiert, beim zweiten Klick ab 10 bis 20 usw. bis halt die 150 in diesem Fall erreicht sind.

Gurß Florian

Answer 5

Hallo Florian,

- sollen die Artikelnummern immer in den Bereich A1 bis A10 geschrieben - also die alten Daten überschrieben - werden?
- gibt es jede Artikelnummer nur einmal im Tabellenblatt Source?

Gruß

M.O.

Answer 6

Hallo,

ich wußte, ich hatte ein Deja-vue ;-).

Gruß

M.O.

Answer 7

Hallo Mo,

ja sie sollen immer in die Spalte A1 bis Aa10 geschrieben werden und die 10 Artikelnummern sollen immer wieder überschrieben werden.Die Artikelnummern kommen immer nur einmal vor.
Deja-vue kann schon sein :-)

Gruß Florian

Answer 8

Hey Mo,

ich meinte A1 bis A10. Hatte einen Tippfehler vorhin drin.

Gruß Florian

Answer 9

Hallo Florian,

ich habe Nightys Makro (siehe Linka aus Anwort 6) mal auf deine Verhältnisse angepasst:

Global IndexPos As Long
Global ArrQ As Variant
Sub copy10()
Dim Zaehler1 As Long
Dim Zaehler2 As Long

Worksheets("Ausgabe").Range("A1:A10").Clear

If IndexPos = 0 Then
With Worksheets("Source")
ArrQ = .Range(.Cells(1, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 1))
End With
IndexPos = 1
End If

If IndexPos > UBound(ArrQ) Then
With Worksheets("Source")
ArrQ = .Range(.Cells(1, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 1))
End With
IndexPos = 1
End If

For Zaehler1 = IndexPos To IndexPos + 9
If Zaehler1 > UBound(ArrQ) Then Exit For
Zaehler2 = Zaehler2 + 1
Worksheets("Ausgabe").Cells(Zaehler2, 1) = ArrQ(Zaehler1, 1)
Next Zaehler1

IndexPos = IndexPos + Zaehler2

End Sub

Gruß

M.O.

Answer 10

Hallo Mo,

das hat soweit gut geklappt. Ich würde lieber gerne die Spalte C6:C15 verwenden.
Ich konnte schon es an dieser stelle (Worksheets("Ausgabe").Cells(Zaehler2, 3) = ArrQ(Zaehler1, 1)
Next Zaehler1 ) bereits ändern. Nur leider fängt es immer noch ab C1 an. Ich weiss ist ne kleinigkeit.
Danke und

Gruß Florian