VBA für Zellenabgleich und div. Operationen
23.07.2015 16:28:33
Adrian
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