Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1436to1440
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA für Zellenabgleich und div. Operationen

VBA für Zellenabgleich und div. Operationen
23.07.2015 16:28:33
Adrian
Hallo Community!
Ich stehe auf der Arbeit grad vor folgendem Problem:
Und zwar habe ich 2 Tabellenblätter (Quelle und Ziel) die ich möglichst in einem Abwasch
1.) auf bereits vorhandene vorgangsnummern (in beiden Blättern im Bereich A2 bis letzte Zeile mit Inhalt) vergleichen und falls nicht in "Ziel" vorhanden aus "Quelle" kopieren und am besten in eine frisch eingefügte Zeile in "Ziel" hinte rdem letzten Eintrag einfügen möchte, und
2.) Wenn Vorgangsnummer bereits in beiden Blättern vorhanden, bei Spalten "S" und "W" die Einträge aus "Quelle" mit "Ziel" vergleichen und bei änderung die Werte übernehmen und farbig in "Ziel" hervorheben
3.) Datensätze, die zwar noch in "Ziel" sind, aber nicht mehr in "Quelle", einfach grau zu hinterlegen...
Ich habe mir dazu bisher folgendes zusammengegaunert :D

Option Explicit
Sub Abgleich()
Dim DupliArr As Variant, MasterArr As Variant, LZ1 As Long, LZ2 As Long, ZeileD As Long, ZeileU  _
_
_
_
As Long, ZeileE As Long, ZeileV As Long, sh1 As Worksheet, sh2 As Worksheet
Set sh1 = Sheets(2)
Set sh2 = Sheets(1)
LZ1 = IIf(IsEmpty(sh1.Cells(sh1.Rows.Count, 1)), sh1.Cells(sh1.Rows.Count, 1).End(xlUp).Row,  _
sh1.Rows.Count) 'Quellbereich
LZ2 = IIf(IsEmpty(sh2.Cells(sh2.Rows.Count, 1)), sh2.Cells(sh2.Rows.Count, 1).End(xlUp).Row,  _
sh2.Rows.Count) 'Zielbereich
DupliArr = sh1.Range("A2:A" & LZ1)
MasterArr = sh2.Range("A2:A" & LZ2)
sh2.Range("A2:A" & LZ2).Interior.ColorIndex = 0 'sauber machen
sh2.Range("S2:S" & LZ2).Interior.ColorIndex = 0
sh2.Range("W2:W" & LZ2).Interior.ColorIndex = 0
For ZeileD = 2 To LZ1
For ZeileU = 2 To LZ2
If sh1.Cells(ZeileD, 1).Value = sh2.Cells(ZeileU, 1).Value And sh1.Cells(ZeileD, 19). _
Value  sh2.Cells(ZeileU, 19).Value Then        'vergleich
sh1.Rows(ZeileD).Copy sh2.Rows(ZeileU)
sh2.Cells(ZeileU, 19).Interior.ColorIndex = 3
End If
Next ZeileU
Next ZeileD
Dim rngQuelle As Range
Dim rngZiel As Range
For Each rngZiel In sh2.Range("A2:A" & LZ2)
On Error Resume Next
Set rngQuelle = sh1.Range("A2:A" & LZ2).Find(What:=rngZiel)
On Error GoTo 0
If Not rngQuelle Is Nothing Then
rngQuelle.EntireRow.Copy
rngZiel.EntireRow.PasteSpecial Paste:=xlPasteValues
End If
Next
End Sub

Die Erste Schleife haut schon ganz gut hin, bis auf die Tatsache, dass nur eine Änderung in der betreffenden Zeile farbig wird (vllt. muss da mit Range hantiert werden, als die komplette row zu vergleichen?)
Die zweite schleife läuft ohne Debug durch, bewirkt aber keine Veränderung in den Tabellen...
Großartig wäre außerdem, wenn man vor der Ausführung des eigentlichen Makros eine Abfrage starten könnte, die zumindest die "Quelle" (eigentlich aus jeweils verschiedenen workbooks stammend) von einem beliebigen ort auf der Festplatte laden kann...
sowas wie:

Public Sub Update()
Dim var As Variant
MsgBox "Please locate the new extracts.", vbInformation
ChDrive "P:"
ChDir "\QUALITY\CABCARGOQUALITY\040_QECM\080_KSI Mod efficiency\030_EC Filtered lists ( _
alignment)"
var = Application.GetOpenFilename("Excel-Dateien (*.xls; *.xlsx),*.xlsx; *.xls", MultiSelect:=   _
_
_
False)
If var = False Then
MsgBox "No File selected, exiting."
Exit Sub
Else
Workbooks.Open var
End If
End Sub

Bitte um Hilfe :-)
LG
Adrian

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA für Zellenabgleich und div. Operationen
24.07.2015 09:52:42
Adrian
Kann keiner helfen? :(
Vorerst reichte es mir schon, eine Lösung für Copy/Paste-Prozedur zu finden, die nur die neuen Einträge in die vorhandene "Ziel" Datei überträgt... Ich habe mit der Schleife noch irgendwie meine Probleme:

For ZeileD = 2 To LZ1
For ZeileU = 2 To LZ2
If sh1.Cells(ZeileD, 1).Value  sh2.Cells(ZeileU, 1).Value And sh1.Cells(ZeileD, 1). _
Value  "" Then       'insert new
sh2.Range("A2").End(xlDown).Offset(1, 0).EntireRow.Insert
sh1.Rows(ZeileD).Copy Destination:=sh2.Rows(ZeileU)
sh2.Cells(ZeileU, 1).Interior.ColorIndex = 2
End If
Next ZeileU
Next ZeileD
Dieser Code läuft auch durch, macht aber nicht das was er soll^^ Ich nimmt nur den Inhalt der letzten Reihe in "Quelle" und schmeisst ihn einfach in jede Zelle des "Ziels"... Ich sehe einfach kein Land mehr :-(
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige