Zeile kopieren und in neues Tabellenblatt einfügen
Hallo,
ich habe mal wieder ein Problem.
Ich habe zwei Tabellenblätter (Tab1 und Tab2). In Tab1 steht in Spalte F Werte (ab Zeile 2). Wenn dieser Wert in Spalte 1 auf Tab2 gefunden wird, dann soll die komplette Zeile aus Tab1 unterhalb des gefundenen Wertes in Tab2 eingefügt werden. Das Suchen und finden klappt schon, aber bei dem Einfügen hab ich noch Probleme, weil eben das Tabellenblatt gewechselt wird. Ich hoffe es ist einigermaßen verständlich und mir kann jemand wieder so toll weiterhelfen, wie beim letzten Mal.
Dankeschön schon mal im Voraus
ich habe mal wieder ein Problem.
Ich habe zwei Tabellenblätter (Tab1 und Tab2). In Tab1 steht in Spalte F Werte (ab Zeile 2). Wenn dieser Wert in Spalte 1 auf Tab2 gefunden wird, dann soll die komplette Zeile aus Tab1 unterhalb des gefundenen Wertes in Tab2 eingefügt werden. Das Suchen und finden klappt schon, aber bei dem Einfügen hab ich noch Probleme, weil eben das Tabellenblatt gewechselt wird. Ich hoffe es ist einigermaßen verständlich und mir kann jemand wieder so toll weiterhelfen, wie beim letzten Mal.
Dankeschön schon mal im Voraus
Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben
Content-ID: 120780
Url: https://administrator.de/contentid/120780
Ausgedruckt am: 22.11.2024 um 21:11 Uhr
9 Kommentare
Neuester Kommentar
Hi,
hier mal ein kleines VBA Beispiel:
Vielleicht hilfts Dir ja weiter.
Viele Grüße
Bernd
hier mal ein kleines VBA Beispiel:
'Also hier gehts weiter nachdem die Auswahl selektiert wurde
Selection.Copy
Sheets("Name des Ziel Datenblattes").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Vielleicht hilfts Dir ja weiter.
Viele Grüße
Bernd
Hallo Schnufflchen!
Das sollte funktionieren:
Gruß Dieter
Das sollte funktionieren:
Option Explicit
Option Compare Text
Sub Test()
Dim Wks1 As Worksheet, Wks2 As Worksheet, Found As Range, c As Range
Set Wks1 = Sheets("Tabelle1"): Set Wks2 = Sheets("Tabelle2")
Application.ScreenUpdating = False
With Wks1
For Each c In .Range("F2:F" & .Cells(.Rows.Count, "F").End(xlUp).Row)
If Not IsEmpty(c) Then
Set Found = Wks2.Columns("A").Find(c, LookIn:=xlValues, LookAt:=xlWhole)
If Not Found Is Nothing Then
.Rows(c.Row).Copy: Wks2.Rows(Found.Row + 1).Insert Shift:=xlDown
End If
End If
Next
End With
Application.CutCopyMode = False: Application.ScreenUpdating = True
End Sub
Gruß Dieter
Hallo Schnufflchen!
Na, dann erkläre ich mal
Gruß Dieter
Na, dann erkläre ich mal
Option Explicit
'Hiermit wird verlangt, dass alle benutzten Variablen definiert werden.
Option Compare Text
'Hiermit wird festgelegt, dass bei Vergleichs-Operationen (Like, Find...)
'NICHT zwischen Groß/Klein-Schreibung unterschieden wird.
Sub Test()
Dim Wks1 As Worksheet, Wks2 As Worksheet, Found As Range, c As Range
Set Wks1 = Sheets("Tabelle1"): Set Wks2 = Sheets("Tabelle2")
'Bei Abläufen in verschiedenen Tabs empfielt es sich, die Tabellenblätter explizit
'einer Variablen zuzuordnen und diese darüber anzusprechen.
Application.ScreenUpdating = False
'Deaktiviert die Bildschirmaktualisierung während der Makro-Ausführung.
'Das Makro wird schneller ausgeführt und der Bildschirm flackert nicht.
With Wks1
'Alle nachfolgenden Anweisungen, die mit einem Punkt beginnen, sind dem
'Tabellenblatt Wks1 zuzuordnen.
For Each c In .Range("F2:F" & .Cells(.Rows.Count, "F").End(xlUp).Row)
'c steht für jede einzelne Zelle im Bereich F2:F & Letzte Zeile mit Inhalt in Spalte F
If Not IsEmpty(c) Then 'Keine leere Zellen
Set Found = Wks2.Columns("A").Find(c, LookIn:=xlValues, LookAt:=xlWhole)
'Found ist Zelle, in der der Wert gefunden wurde (xlWohle vergleicht ganzen Zellinhalt)
If Not Found Is Nothing Then 'Wenn gefunden dann
.Rows(c.Row).Copy: Wks2.Rows(Found.Row + 1).Insert Shift:=xlDown
'Zeile mit Suchwert kopieren und in einer neuen Zeile gefunden +1 einfügen
End If
End If
Next
End With
Application.CutCopyMode = False: Application.ScreenUpdating = True
'Die Kopiermarkierung aufheben und die Bildschirmaktualisierung wieder aktivieren
End Sub
Gruß Dieter
Hallo Schnufflchen!
So einfach geht das nicht
Werte aus Tab1 von Spalte A-F in Tab2 in neue Zeile Spalte F-K in etwa so:
Oder in Tab2 gleiche Zeile Spalte B-G:
Gruß Dieter
So einfach geht das nicht
Werte aus Tab1 von Spalte A-F in Tab2 in neue Zeile Spalte F-K in etwa so:
If Not Found Is Nothing Then
Wks2.Rows(Found.Row + 1).Insert Shift:=xlDown 'Neue Zeile in Tab2 einfügen
.Range(c.Offset(0, -5), c.Offset(0, 0)).Copy Destination:=Wks2.Cells(Found.Row + 1, 6)
Oder
.Range(c.Offset(0, -5), c).Copy Destination:=Wks2.Cells(Found.Row + 1, 6)
'In Tab1 Spalte A-F nach Tab2 in neue Zeile Spalte F-K kopieren
End If
If Not Found Is Nothing Then
.Range(c.Offset(0, -5), c.Offset(0, 0)).Copy Destination:=Wks2.Cells(Found.Row , 2)
Oder
.Range(c.Offset(0, -5), c).Copy Destination:=Wks2.Cells(Found.Row , 2)
'In Tab1 Spalte A-F nach Tab2 gleiche Zeile Spalte B-G kopieren
End If
Gruß Dieter
Hallo
Ich weis der Thread ist schon etwas alt, aber ich da trotzdem mal ´ne Frage: (Excel 2010)
ich will, dass Werte aus Spalte B (ab B2 bis letzte beschriebene) in ein 2. Tabellenblatt in Spalte E kopieren. Dafür habe ich dein Skript etwas an die Gegebenheiten angepasst, jedoch passiert beim Starten des Makros genau gar nichts :/ Ich bin Einsteiger in VBA/Programmieren allgemein und finde deswegen auch keinen Fehler. Kannst du mir helfen?
Option Compare Text
Option Explicit
Sub KopierenAdm()
Dim T1 As Worksheet, T2 As Worksheet, Found As Range, c As Range
Set T1 = Sheets("Tabelle1"): Set T2 = Sheets("Tabelle2")
Application.ScreenUpdating = False
With T1
For Each c In .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
If Not IsEmpty(c) Then
Set Found = T2.Columns("E").Find(c, LookIn:=xlValues, LookAt:=xlWhole)
If Not Found Is Nothing Then
.Rows(c.Row).Copy: T2.Rows(Found.Row + 1).Insert Shift:=xlDown
End If
End If
Next
End With
Application.CutCopyMode = False: Application.ScreenUpdating = True
End Sub
Vielen Dank im Vorraus
Ich weis der Thread ist schon etwas alt, aber ich da trotzdem mal ´ne Frage: (Excel 2010)
ich will, dass Werte aus Spalte B (ab B2 bis letzte beschriebene) in ein 2. Tabellenblatt in Spalte E kopieren. Dafür habe ich dein Skript etwas an die Gegebenheiten angepasst, jedoch passiert beim Starten des Makros genau gar nichts :/ Ich bin Einsteiger in VBA/Programmieren allgemein und finde deswegen auch keinen Fehler. Kannst du mir helfen?
Option Compare Text
Option Explicit
Sub KopierenAdm()
Dim T1 As Worksheet, T2 As Worksheet, Found As Range, c As Range
Set T1 = Sheets("Tabelle1"): Set T2 = Sheets("Tabelle2")
Application.ScreenUpdating = False
With T1
For Each c In .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
If Not IsEmpty(c) Then
Set Found = T2.Columns("E").Find(c, LookIn:=xlValues, LookAt:=xlWhole)
If Not Found Is Nothing Then
.Rows(c.Row).Copy: T2.Rows(Found.Row + 1).Insert Shift:=xlDown
End If
End If
Next
End With
Application.CutCopyMode = False: Application.ScreenUpdating = True
End Sub
Vielen Dank im Vorraus