Abgleich auf neue Einträge

Hallo VBA Freunde,
ich habe mich heute an der folgenden Problemstellung versucht,
Es gibt 2 Worksheets in einer Excel Datei,
in Sheet1 erscheinen in Spalte C - in den Zellen C1:C1000+ in abwechselnder Reihenfolge jeweils immer die gleichen 10 "Anbieter"
Von Zeit zur Zeit kommen aber neue Produkte auf dem Markt und damit in den neuen Zeilen (und in Spalte B) neue Anbieter.
Sheet2 enthält eine Auswertungsdatei, wo die Daten von Sheet1 aggregiert/ zusammengefasst werden.
Dort sind in den Zeilen A5 bis A15 die verfügbaren 10 Anbieter mit dem Namen bereits gelistet. (Zeile A16 enthält eine Summenzeile)
Die Aufgabe besteht also darin zu schauen ob in Sheet1 neue Anbieter in Spalte C hinzugekommen sind, die nicht schon in Sheet2 gelistet sind.
Sind neue Anbieter dabei, so sollen diese mit dem Namen aus Sheet1 Spalte C automatisch in Sheet2 in Zelle A16, ...A17, ... A18 usw. (.Insert Shift:=xlShiftDown) übertragen werden.
Besten Dank für Anregungen und Ideen!
Hier mein Versuch (Code), der noch nicht läuft und nicht wirklich sehr gelungen ist. Es muss anders einfacher gehen...
LastRowWs1 = wb1.Worksheets(("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
LastRowsWs2 =wb1.Worksheets(("Sheet2").(1, Columns.Count).End(xlToLeft).Column
wb1.Worksheets("Sheet2").Activate
For j=2 To LastRowWs1
If wb1.Worksheets("Sheet1").Cells(j,3).Value _
wb1.Worksheets("Sheet2").Range(Cells(5,1), Cells(LastRowWs2 -1,1) Then
k=wb1.Worksheets("Sheet1").Cells(j,3).Value
ActiveSheet.Rows(LastRowsWs2).Insert Shift:=xlShiftDown, CopyOrigin:= xlFormatFromLeftOrAbove
Cells(LastRowWs2,1).Value = k
End If
Next j
Grüße Heiko

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Heiko,
ganz so einfach ist es dann doch nicht, denn man muss ja auch dafür sorgen, dass ggf. mehrfach vorkommende neue Namen nicht mehrfach übertragen werden.
Hier mein Lösungsvorschlag - er funktioniert unabhängig davon in welcher Zeile die neuen Namen in Spalte C im Blatt1 stehen.
Gruß
Franz

Sub GetNewNames()
Dim wks1 As Worksheet, wks2 As Worksheet
Dim Zeile As Long, Zeile_L2 As Long, Zeile_2 As Long, StatusCalc As Long
Dim arrNamen As Variant
Dim colNamen As New Collection
Const bolFormeln As Boolean = True 'wenn False, dann wird nur jeweils leere _
Zeile mit Anbietername eingefügt, bei True Zeile mit Formeln kopiert
'Makrobremsen lösen
With Application
.ScreenUpdating = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
On Error GoTo Fehler
Set wks1 = ActiveWorkbook.Worksheets("Tabelle1") 'Blatt mit Detaildaten
Set wks2 = ActiveWorkbook.Worksheets("Tabelle2") 'Blatt mit Summierungen
'Anbieter-Namen in Blatt1 in Daten-Array übernehmen - beschleunigt bei vielen Zeilen _
die Makroausführung
With wks1
'letzte Zeile mit Anbieter in Spalte C in Blatt 1
Zeile = .Cells(.Rows.Count, 3).End(xlUp).Row
If Zeile = 1 Then
ReDim arrNamen(1 To 1, 1 To 1): arrNamen(1, 1) = .Cells(1, 3).Text
Else
arrNamen = .Range(.Cells(1, 3), .Cells(Zeile, 3))
End If
End With
'Liste mit Anbieter-Namen in Blatt1 ohne doppelte erstellen
For Zeile = 1 To UBound(arrNamen, 1)
If arrNamen(Zeile, 1)  "" Then
colNamen.Add arrNamen(Zeile, 1), arrNamen(Zeile, 1)
End If
Next
With wks2
'letzte Zeile mit Inhalt in Spalte A in Blatt 2
Zeile_L2 = .Cells(.Rows.Count, 1).End(xlUp).Row
'vorhandenen Namen aus Blatt 2 in Liste löschen
For Zeile_2 = 5 To Zeile_L2 - 1
For Zeile = colNamen.Count To 1 Step -1
If colNamen(Zeile) = .Cells(Zeile_2, 1).Text Then
colNamen.Remove (Zeile)
Exit For
End If
Next
Next
'Neue Namen in Blatt2 einfügen
For Zeile = 1 To colNamen.Count
If bolFormeln = True Then
'Zeile oberhalb der Summenzeile kopieren und einfügen - sorgt dafür, _
dass die Zellbezüge in der Summenzeile mit aktualisiert werden
With .Rows(Zeile_L2 - 1)
.Copy
.Insert Shift:=xlShiftDown
Application.CutCopyMode = False
End With
Else
.Rows(Zeile_L2).Insert
End If
'Anbieter in neue Zeile oberhalb der Summenzeile eintragen
.Cells(Zeile_L2, 1).Value = colNamen(Zeile)
Zeile_L2 = Zeile_L2 + 1
Next
End With
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case 457 'doppelter Eintrag bei Erstellung der Collection
Resume Next
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
'Makrobremsen zurücksetzen
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
End With
End Sub

Beliebteste Forumthreads (12 Monate)

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread