Bereich aus Tab1 in Tab2 kopieren

Hi Zusammen,
Habe einen VBA Code bekommen den ich jetzt noch nach meinen Wünschen anpassen muss.
Ich möchte aus einem bestimmten Bereich in Tabelle1 die Daten per VBA in Tabelle 2 kopiert haben.
Funktioniert mit unten stehenden Code auch gut. Jedoch soll er nur die Zeilen Kopieren wo in Spalte B die Zahlen Fett markiert sind.
Hab schon Variable.Font.Bold probiert, geht aber nicht.
Weiterhin soll er in Tabelle2 prüfen ob die Zahl in Spalte B schon vorhanden ist. Dann soll er die Zeilen auch nicht mit kopieren.


Sub CopyData()
Dim lngLastRow1 As Long, lngLastRow2 As Long
lngLastRow1 = Sheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row
lngLastRow2 = Sheets("Tabelle2").Cells(Rows.Count, 1).End(xlUp).Row
If lngLastRow1 > 1 Then
Sheets("Tabelle1").Range("A2:B" & lngLastRow1).Copy
Sheets("Tabelle2").Range("A" & lngLastRow2).PasteSpecial xlValues
Application.CutCopyMode = False
End If
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub CopyData() Dim lngLastRow1 As Long, lngLastRow2 As Long, raKopy As Range lngLastRow1 = Sheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row lngLastRow2 = Sheets("Tabelle2").Cells(Rows.Count, 1).End(xlUp).Row If lngLastRow1 > 1 Then With Sheets("Tabelle1") For i = 2 To lngLastRow1 If .Cells(i, "B").Font.Bold Then If raKopy Is Nothing Then Set raKopy = .Cells(i, "A").Resize(, 2) Else Set raKopy = Union(raKopy, .Cells(i, "A").Resize(, 2)) End If End If Next i If Not raKopy Is Nothing Then raKopy.Copy Sheets("Tabelle2").Cells(lngLastRow2, "A").PasteSpecial Paste:=xlPasteValues End If End With End If Application.CutCopyMode = False Set raKopy = Nothing End Sub

Sub aaa() Dim rngKopie As Range, rngC As Range With Tabelle1.Cells(1, 1) For Each rngC In Intersect(.CurrentRegion, .CurrentRegion.Offset(1)).Resize(, 1) If rngC.Offset(, 1).Font.Bold Then If Application.CountIf(Tabelle2.Columns(2), rngC.Offset(, 1)) = 0 Then If rngKopie Is Nothing Then Set rngKopie = rngC.Resize(, 2) Else Set rngKopie = Union(rngKopie, rngC.Resize(, 2)) End If End If End If Next rngC End With If Not rngKopie Is Nothing Then rngKopie.Copy Tabelle2.Cells(Rows.Count, 1).End(xlUp).Offset(1) End If End Sub

Sub CopyData() Dim lngLastRow1 As Long, lngLastRow2 As Long, r As Long lngLastRow1 = Sheets("Tabelle1").Cells(Rows.Count, 2).End(xlUp).Row lngLastRow2 = Sheets("Tabelle2").Cells(Rows.Count, 1).End(xlUp).Row If lngLastRow1 > 1 Then For r = 2 To lngLastRow1 If WorksheetFunction.CountIf(Sheets("Tabelle2").Columns("B"), Sheets("Tabelle1").Cells(r, 2)) = 0 Then If Sheets("Tabelle1").Cells(r, 2).Font.Bold = True Then lngLastRow2 = lngLastRow2 + 1 Sheets("Tabelle1").Range("A" & r & ":B" & r).Copy Sheets("Tabelle2").Range("A" & lngLastRow2).PasteSpecial xlValues Application.CutCopyMode = False End If End If Next End If End Sub

Beliebteste Forumthreads (12 Monate)

Bereich aus Tab1 in Tab2 kopieren

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread