AW: Datenänderung via Änderungsprotokoll
20.04.2022 15:00:38
Nepumuk
Hallo Jana,
teste mal:
Option Explicit
Public Sub Transferred()
Dim objSearch As Object, objChange As Object
Dim objItem As Range, objCell As Range
Dim lngRow As Long, lngChangeRow As Long
Set objSearch = CreateObject(Class:="Scripting.Dictionary")
Set objChange = CreateObject(Class:="Scripting.Dictionary")
With Worksheets("Änderungsprotokoll")
For Each objItem In .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
If Not objSearch.Exists(Key:=objItem.Text) Then
Set objCell = Worksheets("Datenbasis").Rows(1).Find(What:=objItem.Text, _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not objCell Is Nothing Then
Call objSearch.Add(Key:=objItem.Text, Item:=objCell.Column)
Set objCell = Nothing
Else
Call MsgBox("Spalte ''" & objItem.Text & _
"'' in Tabelle ''Datenbasis'' nicht gefunden.", vbCritical, "Programmabbruch")
Exit Sub
End If
End If
Next
For Each objItem In .Range(.Cells(2, 3), .Cells(.Rows.Count, 3).End(xlUp))
If Not objChange.Exists(Key:=objItem.Text) Then
Set objCell = Worksheets("Datenbasis").Rows(1).Find(What:=objItem.Text, _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not objCell Is Nothing Then
Call objChange.Add(Key:=objItem.Text, Item:=objCell.Column)
Set objCell = Nothing
Else
Call MsgBox("Spalte ''" & objItem.Text & _
"'' in Tabelle ''Datenbasis'' nicht gefunden.", vbCritical, "Programmabbruch")
Exit Sub
End If
End If
Next
For lngRow = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
Set objCell = Worksheets("Datenbasis").Columns(objSearch.Item(Key:=.Cells(lngRow, 1).Text)).Find( _
What:=.Cells(lngRow, 2).Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not objCell Is Nothing Then
Worksheets("Datenbasis").Cells(objCell.Row, _
objChange.Item(Key:=.Cells(lngRow, 3).Text)).Value = .Cells(lngRow, 4).Value
Else
Call MsgBox("Suchbegriff ''" & .Cells(lngRow, 2).Text & "'' in Spalte ''" & .Cells(lngRow, 3).Text & _
"'' der Tabelle ''Datenbasis'' nicht gefunden.", vbCritical, "Programmabbruch")
End If
Next
End With
Set objSearch = Nothing
Set objChange = Nothing
End Sub
Der Code gehrt in ein Standardmodul (Menüleiste im VBA-Editor Einfügen - Modul).
Gruß
Nepumuk