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,

du musst die Zeile wie folgt ändern, da ja der Zähler immer bei 1 anfängt:

Worksheets("Ausgabe").Cells(Zaehler2 + 5, 3) = ArrQ(Zaehler1, 1)

Gruß

M.O.

Answer 2

Hallo Mo,

vielen Dank für deine Hilfe es hat alles soweit gut geklappt.
Eine Sache wäre da noch, ist nur ein kleiner schönheitsfehler.
bei der letzeten Makro

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+5, 3) = ArrQ(Zaehler1, 1)
Next Zaehler1

IndexPos = IndexPos + Zaehler2

End Sub



gibt es ein kleines Problem. Jetzt habe ich mir in die Source Tabelle neue Artikelnummern per Makro eingelesen. Und diese mal waren es nur 13 Einträge. Das varriert ja immer, mal mehr mal weniger.
Als ich dann die Global IndexPos As Long Marko laufen lies, hat immer noch die alten Artikelnummern (die von der Anzahl der Artikelnummer ca. 150 stck waren) weiterhin bis zum ende Eingelesen.
Hast Du da einen Tipp?

Gruß Florian

Answer 3

Hallo Florian,

ich gehe mal davon aus, dass sich die Artikelnummern beim Import nicht wiederholen. Daher probiere mal das Makro:

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

Worksheets("Ausgabe").Range("A1:A10").Clear
lzeile = Worksheets("Source").Cells(Rows.Count, 1).End(xlUp).Row

If IndexPos = 0 Then
With Worksheets("Source")
ArrQ = .Range(.Cells(1, 1), .Cells(lzeile, 1))
End With
IndexPos = 1
End If

If IndexPos > UBound(ArrQ) Then
With Worksheets("Source")
ArrQ = .Range(.Cells(1, 1), .Cells(lzeile, 1))
End With
IndexPos = 1
End If

With Worksheets("Source")
If .Cells(lzeile, 1).Value <> ArrQ(UBound(ArrQ), 1) Then
ArrQ = .Range(.Cells(1, 1), .Cells(lzeile, 1))
IndexPos = 1
End If
End With

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

Hier wird zusätzlich noch einmal überprüft, ob die Artikelnummer in der letzten Zeile der Quelltabelle der letzten Artikelnummer im Array entspricht. Ist das nicht der Fall, wird das Array neu eingelesen.

Gruß

M.O.

Answer 4

Hallo Mo,

Danke Dir dass hat super funktioniert. Jetzt kann ich alle Daten einlesen abspeichern und Ausgeben.
Jetzt bräuchte ich hierbei erneut einen vorschlag oder die dafür geeignete Makro.

Das ist die Makro wenn ich die Artikelnummern aus einer neuen externen Exceldateien in das Tabellenblatt Source einlesen möchte.

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

Next Zelle
End Sub

Nachdem ich die Daten eingelesen habe, konnte ich mit der neuen Makro die Du mir letzte Woche geschrieben hast, immer in 10 ner Schritten die Artikelnummer in das Tabellenblatt Ausgabe einlesen. So...natürlich gibt es zun den Artikelnummern immer Artikelbeschreibungen.
Die Artikelnummern werden in 10ner Schritten in die Zelle C6:C15 hineingelesen.
In den Zellen E6:I15 kommen per Formel die Antworten zu den dazugehörigen Artikelnummern aus Spalte C6:C15.
Was ich nun möchte ist die Ergebnisse aus dem Tabellenblatt Ausgabe E6:I15 kopieren und diese Kopien in die Spalte M der Externen Exceldatei hinein kopieren die ich wie die Marko Sub DATENBANK() auswählen kann.


Gruß Flo

Answer 5

Hallo Mo ,

sorry das war die Falsche Makro die bearbeitet werden sollte.
Das ist die richtige.

Was ich ja gerne möchte ist das ganze quasi wieder Rückwertz laufen zu lassen.
Neue Exceldatein öffnen diese Exceldatei auswählen per inputbox. Wenn dies ausgewählt ist, dann soll die ersten10 information aus der Datenbank Tabellenblatt Userguide I6:I16 die Spalte M1:M10 der neuen Exceldatei hineinkopiert und dann wieder von aus dem Tabellenblatt Userguide I6:I16 in Spalte M der vorher ausgewählten Exceldatei Tabellenblatt Artikelnummer usw.

Sub DATENBANK()

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

Set wb1 = ActiveWorkbook

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

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

Quelltab.Range(Bereich).ClearContents

again:
anex = InputBox("new data")

On Error GoTo again
Workbooks.Open Filename:="C:\..." & abt & ".xls"

Workbooks(abt & ".xls").Activate
Worksheets("Artikelnr").Select
lz = Worksheets("Artikelnr").Cells(Rows.Count, 2).End(xlUp).Row
Workbooks(abt & ".xls").Worksheets("Artikelnr").Range("B3:B" & lz).Copy Destination:=wb1.Worksheets("Source").Range("A1")
Workbooks(abt & ".xls").Close savechanges = False


End Sub

Gruß Flo

Answer 6

Hallo Florian,

wenn ich dich richtig verstanden habe, dann soll das so ablaufen:
1. Name der Zieldatei in Inputbox eingeben und Zieldatei dann öffnen.
2. Aus dem Tabellenblatt "Userguide" des aktiven Workbooks die Zellen I6:I16 kopieren und den Inhalt in die Zieldatei in das Tabellenblatt "Artikelnr" (???) in die Zellen M1:M10 einfügen.
3. Die geöffnete Datei dann speichern und schließen (???).

Deine geposteten Makros sehen alle ja mehr oder weniger gleich aus. Und dein letztes Makro kopiert ja von der geöffneten Datei aus dem Tabellenblatt "Artikelnr" in die Quelldatei.

Gruß

M.O.

Answer 7

Hallo M.O.

genau so wollte ich das machen wie du das eben aufgelistet hast.
Kannst du mir da helfen?

Alternative wäre das hier was ich mir überlegt hatte.
Wie kann ich in Excel mit vba die Exceldatei die ständig immer mit neuen Tabellenblätter auf gestokckt wird. (dafür habe ich schon ein Makro) die Tabellenblätter per msgbox oder input box auswählen und dann aus der Datenbank in die Tabellenblatter die ich auswählen kann einfügen ?

Die neuen Tabellenbläter sind beispielsweis Autohersttellner namen.
Tabellenbaltt 1= Datenbank
Tabellenblatt 2,..3...4..5 usw sind Automobilhersteller BMW, Mercedes, Audi usw.
In der Datenbank liegen informationen die ich wenn nötig in die Tabellenblatter 2.. 3..4..usw per makro eintragen möchte. Ich jedoch eine Auswahl haben.
Zum Beispiel im Tabellenblatt 1 = Datenbank steht in der Spalte A4 Federbein in A5 Achse bis A10 irgendwelche informationen. So jetzt will ich per Makro eine Auswahl haben können das ich die Zellen A4 bis A10 in die Tabellenblatter 2 3 4 usw in den Zellen die immer gleich sind in Spalte G:G hinein kopiert. Wichtig es muss möglich sein das ich das Tabellenblatt auswählen kann.

Gruß Flo

Answer 8

Hallo Florian,

eine Messagebox kann nur anzeigen, bzw. du kannst die Tasten abfragen. Eine Auswahl aus z.B. mehreren Tabellenblättern treffen geht nicht. Bei einer Inputbox müsstest du den Namen des Tabellenblatts händisch eingeben. Willst du z.B. die Tabellenblätter per Drop-Down-Menü auswählen, müsstest du dir eine entsprechende Userform erstellen.

Gruß

M.O.

Answer 9

Hallo Mo,

würde es sonst nicht einfach auch so klappen wenn mann diese Makro umschreibt die ich bei Antwort 15 geschrieben habe?


Gruß Flo

Answer 10

Hallo Florian,

klar kann man das wie bei Antwort 5 lösen. Aber eine entsprechende Userform zu erstellen ist gar nicht so schwer ;-). Trau dich einfach mal.
Wegen des Makros schaue ich mal.

Gruß

M.O.