Live-Forum - Die aktuellen Beiträge
Datum
Titel
26.09.2025 18:34:36
Welches Datum gibt mein M-Code aus?
26.09.2025 10:29:46
Wert aus einer Zelle bei jeder Eingabe in neue Zelle
26.09.2025 08:51:00
Teilinhalt einer Zelle vergleichen
25.09.2025 23:04:12
Einen von drei möglichen Einträgen in einer Zeile suchen
Keine passende Antwort im Forumarchiv gefunden?
Stelle deine Frage im Live-Forum
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1988to1992
1988to1992
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

2. Tabelle automatisch befüllen

Forumthread: 2. Tabelle automatisch befüllen

2. Tabelle automatisch befüllen
06.09.2024 09:38:18
KingOfKitchen
Hallo Excel-Profis

ich versuche schon seit einigen Wochen mein Excel-Problem zu lösen, finde allerdings keinen Ansatz.

Hier die Problemstellung.

In Tabelle 1 stehen verschiedene Daten (Kundenname, Kundennummer, Betrag usw)

Diese sollen beim Speichern automatisch in die Tabelle 2 übertragen werden. Beim nächsten speichern der Tabelle 1, sollen die ausgewählten Daten wieder in die Tabelle 2 gespeichert werden, allerdings ohne die alten Daten dabei zu überschreiben (quasi, wenn in Tabelle 2 die Zeile 3 schon mit Daten gefüllt ist, dann sollen die Daten aus Tabelle 1 automatisch in Zeile 4 übertragen werden usw)

Tabelle 1 heißt: Angebot erstellen
Tabelle 2 heißt: Kundentracker

Ich weiß, es ist nicht einfach. Doch ich hoffe jemand hat eine Lösung dafür.

Vielen Dank schon mal im Voraus
Anzeige

18
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: 2. Tabelle automatisch befüllen
06.09.2024 11:27:27
JoWE
Hallo Unbekannter, der seinen Gruß nicht ordentlich mit seinem Namen abschließt,

nö, so schwierig ist das gar nicht.
Das folgende Makro macht genau das und löscht nach dem Kopieren die kopierten Daten aus Tabelle1.
Das Makro ist in der VBA-Umgebung in "Diese Arbeitsmappe" einzufügen. 
Option Explicit

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

  Dim ws1 As Worksheet

  Dim ws2 As Worksheet

  Set ws1 = ThisWorkbook.Sheets("Angebot erstellen")

  Set ws2 = ThisWorkbook.Sheets("Kundentracker")

  Dim myRng As Range

  Set myRng = ws1.Range("A2:E" & ws1.Cells(Rows.Count, 1).End(xlUp).Row)  'geht hier nur bis Spalte "E", also hier anpassen!!!

  myRng.Copy ws2.Cells(ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)

  MsgBox "Daten wurde übertragen!", vbOKOnly + vbInformation

  myRng.Clear

  ws1.Range("A1").Select

  Application.CutCopyMode = False

End Sub


Gruß
Jochen
Anzeige
AW: 2. Tabelle automatisch befüllen
11.09.2024 10:00:54
KingOfKitchen
Hallo Jochen,

erst einmal vielen Dank für die schnelle und hilfreiche Unterstützung. Doch leider (glaube ich) habe ich mein Problem offensichtlich nicht ausreichend beschrieben.

Folgendes....

In Tabelle 1 (Angebot erstellen) steht in Zelle A5 ein Name. Dieser soll beim speichern von Tabelle 1 automatisch in Tabelle 2 (Kundentracker) Zelle A2 übertragen werden.
Ist die Zelle A2 von Tabelle 2 bereits belegt, soll automatisch in Zelle A3 gespeichert werden usw.
Eine löschung der Daten in Tabelle 1 ist nicht unbedingt notwendig.

Mit besten Grüßen

Klaus
Anzeige
AW: 2. Tabelle automatisch befüllen
06.09.2024 11:29:37
MCO
Hallo KingOfKitchen

Das wäre dann wohl mit einem Makro zu lösen:
Beim Speichern alle Daten auf Vorhandensein überprüfen, ggf kopieren.

Du kannst die Aufgabenstellung mit Tabellendaten mal an Chatgpt geben um schon ein Grundgerüst zu bekommen, oder die Tabelle anonymisiert mit einigen Testdaten hier hochladen.

Gruß, MCO
Anzeige
AW: 2. Tabelle automatisch befüllen
11.09.2024 10:02:34
KingOfKitchen
Hallo MCO,

vielen Dank für die schnelle Hilfe.

Mit besten Grüßen,

Klaus
AW: 2. Tabelle automatisch befüllen
11.09.2024 10:13:06
Eifeljoi 5
Hallo
Nur als Frage:
Warum nutzt du nicht Power Query, dann benötigst du kein VBA.
AW: 2. Tabelle automatisch befüllen
11.09.2024 10:23:20
KingOfKitchen
hab es mir grade angeschaut. Klingt zwar sehr interessant, ist bestimmt auch an der ein oder anderen Stelle hilfreich. Allerdings hab ich noch gar keine Erfahrung mit diesem Tool. Vielen Dank aber trotzdem für diesen konstruktiven Beitrag.

Mit besten Grüßen,

Klaus
Anzeige
VBA
06.09.2024 11:31:12
UweD
Hallo

muss in den Codebereich von DieseArbeitsmappe 



Private Sub Workbook_Open()

    Dim Tb1 As Worksheet, Tb2 As Worksheet, LR1 As Long, LR2 As Long

    Dim Z1 As Integer, SP As Integer

    

    Set Tb1 = Sheets("Angebot erstellen")

    Set Tb2 = Sheets("Kundentracker")

    

    Z1 = 2 'erste Datenzeile

    SP = 1 'Salte A Datenspalte

    

    With Tb1

        LR1 = .Cells(.Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte

        LR2 = Tb2.Cells(Tb2.Rows.Count, SP).End(xlUp).Row + 1 'erste freie Zeile in Zielblatt

        

        With .Rows(Z1).Resize(LR1 - Z1 + 1)

            .Copy Tb2.Rows(LR2)

            

            .Delete xlUp 'löschen Eingabeblatt

        End With

    End With

End Sub



LG UweD
Anzeige
AW: VBA
06.09.2024 11:43:23
UweD
Es soll ja beim Speichern geschehen.

Außerdem noch eine Prüfung, wenn keine Daten zum Kopieren da sind 




Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)



    Dim Tb1 As Worksheet, Tb2 As Worksheet, LR1 As Long, LR2 As Long

    Dim Z1 As Integer, SP As Integer

    

    Set Tb1 = Sheets("Angebot erstellen")

    Set Tb2 = Sheets("Kundentracker")

    

    Z1 = 2 'erste Datenzeile

    SP = 1 'Salte A Datenspalte

    

    With Tb1

        LR1 = .Cells(.Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte

        LR2 = Tb2.Cells(Tb2.Rows.Count, SP).End(xlUp).Row + 1 'erste freie Zeile in Zielblatt

        

        If LR1 >= Z1 Then

            With .Rows(Z1).Resize(LR1 - Z1 + 1)

                .Copy Tb2.Rows(LR2)

                

                .Delete xlUp 'löschen Eingabeblatt

            End With

        Else

            MsgBox "Keine Daten"

        End If

    End With

End Sub


LG UweD
Anzeige
AW: VBA
11.09.2024 10:15:12
KingOfKitchen
Hallo UweD,

erst einmal vielen Dank für den schnellen und hilfreichen Support. Ich schätze, ich habe meine Problemstellung wohl offensichtlich nicht ausreichend dargesellt. Sorry dafür.

Folgendes....

In Tabelle 1 (Angebot erstellen) steht in Zelle A5 ein Name, in Zelle A6 eine Straße, in Zelle A7 die Postleitzahl, in Zelle H5 eine Kundenummer usw.....

All diese daten in der Tabelle 1 werden täglich manuell überschrieben. Beim Speichern der Tabelle 1 (Angebot erstellen) sollen nun diese Daten aus den besagten Zellen in die Tabelle 2 (Kundentracker) übertragen werden.

Tabelle 1 Zelle A5 --> Tabelle 2 Zelle A2
Tabelle 1 Zelle A6 --> Tabelle 2 Zelle B2
Tabelle 1 Zelle A7 --> Tabelle 2 Zelle C2

usw...

Wenn allerdings z.Bsp. in Tabelle 2 Zelle A2 Daten vorhanden sind, sollen beim speichern automatisch die besagten Daten in Tabelle 2 Zelle A3 eingefügt werden usw.

Ich hoffe ich habe es dieses mal ausführlich beschrieben.

Vielen Dank im Voraus

Mit besten Grüßen,

Klaus
Anzeige
AW: VBA
11.09.2024 10:39:02
UweD
Dann zeig doch mal eine Musterdatei, wie es Ist, und wie es aussehen soll.
AW: VBA
11.09.2024 15:40:59
UweD
Hallo

so?

Ich habe nicht alle Zellen gefunden.
Dort wo im Array A2 steht, musst du deine richtige Quellzelle eintragen. 


Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

    Dim Tb1 As Worksheet, Tb2 As Worksheet, LR As Long, I As Integer

    Dim Arr

    

    Set Tb1 = Sheets("Angebot erstellen")

    Set Tb2 = Sheets("Kundentracker")

    Arr = Array("A5", "A7", "A8", "B8", "A9", "H7", "H6", "A2", "A2", "A2", "A13", "A16", "B16", "A17", "C32", "C33", "D20", "F23", "G23", "A2", "H23", "A2", "A2", "A2", "A2", "A2", "A2", "A2", "A2", "A2", "A2", "A2", "A2", "A2", "A2", "A2", "A2", "A2", "A2", "A2")

        

        LR = Tb2.Cells.SpecialCells(xlCellTypeLastCell).Row + 1 'erste freie Zeile

        

        For I = 1 To 38

            Tb2.Cells(LR, I) = Tb1.Range(Arr(I - 1)) ' Array beginnt bei 0

            

        Next

        

End Sub

LG UweD
Anzeige
AW: VBA
12.09.2024 10:12:15
KingOfKitchen
Hallo Uwe,

vielen Dank für deine spontane und hilfreiche Unterstützung. Jetzt klappt es so wie ich es mir vorgestellt habe.
AW: VBA
11.09.2024 13:12:45
KingOfKitchen
Hab mal manuell ein Makro erstellt. Mit diesem Makro werden bestimmten Zellen aus Tabelle 1 in bestimmte Zellen von Tabelle 2 übertragen, sobald ich auf den Button DATEN JETZT ÜBERTRAGEN klicke (Button hab ich selber eingefügt und mit dem Makro verknüpft)

Die Schwierigkeit, die ich jetzt noch habe ist, sobald ich in Tabelle 1 die Daten geändert habe und erneut auf den Button DATEN JETZT ÜBERTRAGEN klicke, werden die Daten in Tabelle 2 überschrieben.

Dieses soll verhindert werden. Bei jedem klick auf den Button soll eine neue Zeile in Tabelle 2 für die Übertragung der Daten aus Tabelle 1 genutzt werden.



Sub Datenübertragung()
'
' Datenübertragung Makro
' Übertragen der Daten in Kundentracker
'

'
Selection.Copy
Sheets("Kundentracker").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Angebot erstellen").Select
Range("A5:D5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Kundentracker").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Angebot erstellen").Select
Range("A6:B6").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Kundentracker").Select
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Angebot erstellen").Select
Range("A7:D7").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Kundentracker").Select
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Angebot erstellen").Select
Range("A8").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Kundentracker").Select
Range("C2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Angebot erstellen").Select
Range("B8:C8").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Kundentracker").Select
Range("D2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Angebot erstellen").Select
Range("A9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Kundentracker").Select
Range("E2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Angebot erstellen").Select
Range("H5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Kundentracker").Select
Range("F2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Angebot erstellen").Select
Range("A6:B6").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Kundentracker").Select
Range("G2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("H2").Select
Sheets("Angebot erstellen").Select
ActiveWindow.SmallScroll Down:=3
Range("H10").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Kundentracker").Select
Range("H2").Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWindow.SmallScroll ToRight:=10
Sheets("Angebot erstellen").Select
Range("A13:D13").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Kundentracker").Select
Range("K2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Angebot erstellen").Select
Range("A16").Select
Sheets("Kundentracker").Select
ActiveWindow.SmallScroll ToRight:=-3
Sheets("Angebot erstellen").Select
Range("A14:B14").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Kundentracker").Select
Range("K2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Angebot erstellen").Select
Range("A16").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Kundentracker").Select
Range("L2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Angebot erstellen").Select
Range("B16:C16").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Kundentracker").Select
Range("M2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Angebot erstellen").Select
Range("A17").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Kundentracker").Select
Range("N2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("O2").Select
Sheets("Angebot erstellen").Select
ActiveWindow.SmallScroll Down:=24
Range("C33:H33").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Kundentracker").Select
Range("O2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("O:O").ColumnWidth = 30.11
Range("P2").Select
Sheets("Angebot erstellen").Select
Range("C32").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Kundentracker").Select
Range("P2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("Q2").Select
Sheets("Angebot erstellen").Select
ActiveWindow.SmallScroll Down:=-12
Range("D20").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Kundentracker").Select
Range("Q2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("R2").Select
Sheets("Angebot erstellen").Select
Range("B23").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Kundentracker").Select
Range("R2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("S2").Select
Sheets("Angebot erstellen").Select
Range("F23").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Kundentracker").Select
Range("S2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("T2").Select
Sheets("Angebot erstellen").Select
Range("G23").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Kundentracker").Select
Range("T2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("V2").Select
Sheets("Angebot erstellen").Select
Range("H30").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Kundentracker").Select
Range("V2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
Anzeige
AW: VBA
11.09.2024 13:31:49
Eifeljoi 5
Hallo

Wenn dann VBA sein muss , dann könnte dein VBA Code optimiert aber ungetestet etwa so aussehen. 
Sub Datenübertragung()

    Dim wsAngebot As Worksheet

    Dim wsKundentracker As Worksheet

    Dim Quellbereiche As Variant

    Dim Zielbereiche As Variant

    Dim i As Integer

    

    Set wsAngebot = Sheets("Angebot erstellen")

    Set wsKundentracker = Sheets("Kundentracker")

    

    ' Definieren der Quell- und Zielbereiche

    Quellbereiche = Array("A5:D5", "A6:B6", "A7:D7", "A8", "B8:C8", "A9", "H5", "A6:B6", "H10", "A13:D13", "A14:B14", "A16", "B16:C16", "A17", "C33:H33", "C32", "D20", "B23", "F23", "G23", "H30")

    Zielbereiche = Array("A2", "B2", "B2", "C2", "D2", "E2", "F2", "G2", "H2", "K2", "K2", "L2", "M2", "N2", "O2", "P2", "Q2", "R2", "S2", "T2", "V2")

    

    ' Schleife zum Kopieren und Einfügen der Daten

    For i = LBound(Quellbereiche) To UBound(Quellbereiche)

        wsAngebot.Range(Quellbereiche(i)).Copy

        wsKundentracker.Range(Zielbereiche(i)).PasteSpecial Paste:=xlPasteValues

    Next i

    

    ' Spaltenbreite für Spalte O festlegen

    wsKundentracker.Columns("O:O").ColumnWidth = 30.11

    

    Application.CutCopyMode = False

End Sub
Anzeige
AW: VBA
11.09.2024 14:03:14
KingOfKitchen
Vielen Dank erstmal für die Unterstützung,

aber werden mit diesem Code die Daten aus der 1. Zeile von Tabelle KUNDENTRACKER nicht überschrieben wenn ich die Daten aus Tabelle ANGEBOT ERSTELLEN übertrage ?
AW: VBA
11.09.2024 14:23:59
Eifeljoi 5
Hallo
Wieder ungetestet das immer unten angehangen wird. 
Sub Datenübertragung()

    Dim wsAngebot As Worksheet

    Dim wsKundentracker As Worksheet

    Dim Quellbereiche As Variant

    Dim Zielbereiche As Variant

    Dim i As Integer

    Dim ZielZelle As Range

    Set wsAngebot = Sheets("Angebot erstellen")

    Set wsKundentracker = Sheets("Kundentracker")

    Quellbereiche = Array("A5:D5", "A6:B6", "A7:D7", "A8", "B8:C8", "A9", "H5", "A6:B6", "H10", "A13:D13", "A14:B14", "A16", "B16:C16", "A17", "C33:H33", "C32", "D20", "B23", "F23", "G23", "H30")

    Zielbereiche = Array("A", "B", "B", "C", "D", "E", "F", "G", "H", "K", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "V")

    For i = LBound(Quellbereiche) To UBound(Quellbereiche)

        Set ZielZelle = wsKundentracker.Cells(wsKundentracker.Rows.Count, Zielbereiche(i)).End(xlUp).Offset(1, 0)

        wsAngebot.Range(Quellbereiche(i)).Copy

        ZielZelle.PasteSpecial Paste:=xlPasteValues

    Next i

    wsKundentracker.Columns("O:O").ColumnWidth = 30.11

    Application.CutCopyMode = False

End Sub
Anzeige
AW: VBA
12.09.2024 10:09:07
KingOfKitchen
Hallo Eifeljoi 5,

das funktioniert perfekt genau so wie ich es mir vorgestellt hatte. Vielen Dank dafür

;

Beliebteste Forumthreads (12 Monate)

Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Entdecke mehr
Finde genau, was du suchst

Die erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden

Suche nach den besten Antworten
Unsere beliebtesten Threads

Entdecke unsere meistgeklickten Beiträge in der Google Suche

Top 100 Threads jetzt ansehen
Anzeige