AW: Tabellen vergleichen und anpassen (mit xlShiftDown
14.02.2018 22:16:14
fcs
Hallo Jaci,
hier ein Makro, das nur die Projekte zählt und entsprechende Zeilen einfügt.
Gruß
Franz
Sub Verschieben_4()
Dim wks_Neu As Worksheet
Dim wks_Alt As Worksheet
Dim arrNeu As Variant, arrAlt As Variant
Dim arrPrj()
Dim Zeile_A As Long, Zeile_N As Long, Zeile
Dim varProjekt, AnzahlNeu, AnzahlAlt
Dim Zelle As Range
Dim colPrj As New Collection, intP As Integer
On Error GoTo Fehler
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Set wks_Neu = ActiveWorkbook.Worksheets("Tabelle1")
Set wks_Alt = ActiveWorkbook.Worksheets("Tabelle1")
With wks_Neu
Zeile = .Cells(.Rows.Count, 3).End(xlUp).Row
arrNeu = .Range(.Cells(1, 1), .Cells(Zeile, 3))
End With
With wks_Alt
Zeile = .Cells(.Rows.Count, 4).End(xlUp).Row
arrAlt = .Range(.Cells(1, 4), .Cells(Zeile, 6))
End With
'Projekte zählen in Neu und alt
For Zeile_N = 3 To UBound(arrNeu)
varProjekt = arrNeu(Zeile_N, 3)
colPrj.Add varProjekt, CStr(varProjekt)
intP = intP + 1
ReDim Preserve arrPrj(1 To 3, 1 To intP)
arrPrj(1, intP) = varProjekt
arrPrj(2, intP) = fncZaehlenProjekt(Projekt:=varProjekt, arrProjekt:=arrNeu, Spalte:=3)
arrPrj(3, intP) = fncZaehlenProjekt(Projekt:=varProjekt, arrProjekt:=arrAlt, Spalte:=1)
Resume_Zeile_N:
Next Zeile_N
'in Neu fehlende Projekte auswerten in alt
For Zeile_A = 3 To UBound(arrAlt)
varProjekt = arrAlt(Zeile_A, 1)
colPrj.Add varProjekt, CStr(varProjekt)
intP = intP + 1
ReDim Preserve arrPrj(1 To 3, 1 To intP)
arrPrj(1, intP) = varProjekt
arrPrj(2, intP) = fncZaehlenProjekt(Projekt:=varProjekt, arrProjekt:=arrNeu, Spalte:=3)
arrPrj(3, intP) = fncZaehlenProjekt(Projekt:=varProjekt, arrProjekt:=arrAlt, Spalte:=1)
Resume_Zeile_A:
Next Zeile_A
'gefundene Projekte abarbeiten
For intP = 1 To UBound(arrPrj, 2)
varProjekt = arrPrj(1, intP)
AnzahlNeu = arrPrj(2, intP)
AnzahlAlt = arrPrj(3, intP)
If AnzahlNeu > AnzahlAlt And AnzahlAlt > 0 Then
With wks_Alt
Set Zelle = .Range(.Cells(3, 4), .Cells(.Rows.Count, 4).End(xlUp)).Find( _
What:=varProjekt, LookIn:=xlValues, lookat:=xlWhole)
Zeile = Zelle.Row
Do
Zeile = Zeile + 1
If .Cells(Zeile, 4) varProjekt Then
.Range(.Cells(Zeile, 4), _
.Cells(Zeile + AnzahlNeu - AnzahlAlt - 1, 6)).Insert _
Shift:=xlShiftDown
With .Range(.Cells(Zeile, 4), .Cells(Zeile + AnzahlNeu - AnzahlAlt - 1, _
4))
.Value = varProjekt
.Interior.ColorIndex = 6
End With
Exit Do
End If
Loop
End With
ElseIf AnzahlNeu 0 Then
With wks_Neu
Set Zelle = .Range(.Cells(3, 3), .Cells(.Rows.Count, 3).End(xlUp)).Find( _
What:=varProjekt, LookIn:=xlValues, lookat:=xlWhole)
Zeile = Zelle.Row
Do
Zeile = Zeile + 1
If .Cells(Zeile, 3) varProjekt Then
.Range(.Cells(Zeile, 1), _
.Cells(Zeile + AnzahlAlt - AnzahlNeu - 1, 3)).Insert _
Shift:=xlShiftDown
With .Range(.Cells(Zeile, 3), .Cells(Zeile + AnzahlAlt - AnzahlNeu - 1, _
3))
.Value = varProjekt
.Interior.ColorIndex = 6
End With
Exit Do
End If
Loop
End With
ElseIf AnzahlAlt = 0 Then
With wks_Alt
With .Cells(.Rows.Count, 4).End(xlUp).Offset(1, 0).Resize(AnzahlNeu, 1)
.Value = varProjekt
.Interior.ColorIndex = 4
End With
End With
ElseIf AnzahlNeu = 0 Then
With wks_Neu
With .Cells(.Rows.Count, 3).End(xlUp).Offset(1, 0).Resize(AnzahlAlt, 1)
.Value = varProjekt
.Interior.ColorIndex = 4
End With
End With
End If
Next
Fehler:
With Err
Select Case .Number
Case 0
Case 457
If Zeile_A > 0 Then
Resume Resume_Zeile_A
ElseIf Zeile_N > 0 Then
Resume Resume_Zeile_N
End If
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Function fncZaehlenProjekt(ByVal Projekt, arrProjekt, ByVal Spalte As Integer) As Integer
'Projekt im Array zählen
Dim Anzahl As Integer
Dim Zeile As Long
For Zeile = 3 To UBound(arrProjekt)
If Projekt = arrProjekt(Zeile, Spalte) Then
Anzahl = Anzahl + 1
End If
Next
fncZaehlenProjekt = Anzahl
End Function