AW: zeilen Kopieren nach Tabellen vergleich
14.02.2018 14:19:20
Peter(silie)
Hallo,
Erstelle ein Modul, nenne es wie du möchtest.
Erstelle ein Klassenmodul und nenne es "InformationHandler"
Code des Moduls:
Option Explicit
Sub Execute()
Dim ih As New InformationHandler
Set ih.SuperTable = ThisWorkbook.Sheets("supertabelle")
Set ih.NewTable = ThisWorkbook.Sheets("neue infos")
ih.ExecuteInformationProcessing
End Sub
Code des Klassenmoduls InformationHandler:
Option Explicit
Private Type Information
ID As Long
Type_A As String
Type_C As String
Type_E As String
Type_D As String
Type_F As String
LastChanged As Date
End Type
Private sutable_ As Worksheet
Private newtable_ As Worksheet
Public Property Set SuperTable(ByRef this_ As Worksheet)
Set sutable_ = this_
End Property
Public Property Set NewTable(ByRef this_ As Worksheet)
Set newtable_ = this_
End Property
Public Sub ExecuteInformationProcessing()
Dim NewInformations() As Information
Dim lastRow As Long, i As Long
Dim valueRange As Range, placeToBe As Long
With newtable_
lastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
ReDim NewInformations(lastRow - 4)
For i = 4 To lastRow
NewInformations(i - 4).ID = .Cells(i, 2).Value
NewInformations(i - 4).Type_A = .Cells(i, 1).Value
NewInformations(i - 4).Type_C = .Cells(i, 3).Value
NewInformations(i - 4).Type_D = .Cells(i, 4).Value
NewInformations(i - 4).Type_E = .Cells(i, 5).Value
NewInformations(i - 4).Type_F = .Cells(i, 6).Value
NewInformations(i - 4).LastChanged = .Cells(i, 7).Value
Next i
End With
With sutable_
lastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
Set valueRange = .Range(.Cells(1, 2), .Cells(lastRow, 2))
For i = LBound(NewInformations) To UBound(NewInformations)
placeToBe = Index(valueRange, NewInformations(i).ID)
If placeToBe > 0 Then
.Cells(placeToBe, 1).Value = NewInformations(i).Type_A
.Cells(placeToBe, 3).Value = NewInformations(i).Type_C
.Cells(placeToBe, 4).Value = NewInformations(i).Type_D
.Cells(placeToBe, 5).Value = NewInformations(i).Type_E
.Cells(placeToBe, 6).Value = NewInformations(i).Type_F
.Cells(placeToBe, 7).Value = NewInformations(i).LastChanged
End If
Next i
End With
End Sub
Private Function Index(ByRef area As Range, ID As Long) As Long
If Not VBA.IsError(Application.Match(ID, area, 0)) Then
Index = Application.Match(ID, area, 0)
End If
End Function
Oder Alternativ hier deine Datei mit Code:
https://www.herber.de/bbs/user/119800.xlsm