Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1608to1612
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

Tabellen vergleichen und anpassen (mit xlShiftDown

Tabellen vergleichen und anpassen (mit xlShiftDown
12.02.2018 13:52:54
Jaci
Hallo liebes Forum,
Ich habe folgendes Problem.
Ich möchte im ferneren Sinne 2 Tabellen vergleichen. ( siehe File )
Tabelle 1 = A:C
Tabelle 2 = D:F
Im engeren Sinne geht es darum, die Projekte zu vergleichen, also Spalten C und D.
Die linke Tabelle spiegelt einen neuen Datenstand wieder, den ich in einer Tabelle neu verarbeiten möchte. Diese alte Tabelle befindet sich rechts davon , also ab Spalte D.
Dort, wo auf der linken Seite neue Zeilen( also zusätzliche Meilensteine) für ein einzelnes Projekt verfügbar sind, müssen diesen in der rechten Tabelle nach unten verschoben werden und hinzugefügt werden.
Und umgekehrt auch so.
Wie das Final aussehen soll, ist in "Tabelle2" zu sehen.
Meine Frage: Wie kann ich das in VBA umsetzen?
Zum File : https://www.herber.de/bbs/user/119740.xlsm
Beste Grüße & vielen Dank im Voraus.

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Tabellen vergleichen und anpassen (mit xlShiftDown
12.02.2018 22:14:28
fcs
Hallo Jaci,
ich hab jetzt eine eigene Variante angepasst, die nicht nur die Projekte zählt und verschiebt, sondern alle 3 Spalten vergleicht und entsprechende Einfügungen macht.
Gruß
Franz

Sub Verschieben_2()
Dim wks_Neu As Worksheet
Dim wks_Alt As Worksheet
Dim arrNeu As Variant, arrAlt As Variant
Dim VergleichNeu(), VergleichAlt()
Dim Zeile_A As Long, Zeile_N As Long, Zeile
Dim varProjekt, varMeilenstein
Dim Zelle As Range
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
ReDim VergleichNeu(1 To Zeile)
'Die 3 Werte in den Spalten zu einem Vergleichswert zusammenfssen
For Zeile_N = 3 To Zeile
VergleichNeu(Zeile_N) = arrNeu(Zeile_N, 3) & "|" & arrNeu(Zeile_N, 2) & "|" _
& arrNeu(Zeile_N, 1)
Next
With wks_Alt
Zeile = .Cells(.Rows.Count, 4).End(xlUp).Row
arrAlt = .Range(.Cells(1, 4), .Cells(Zeile, 6))
End With
ReDim VergleichAlt(1 To Zeile)
'Die 3 Werte in den Spalten zu einem Vergleichswert zusammenfssen
For Zeile_A = 3 To Zeile
VergleichAlt(Zeile_A) = arrAlt(Zeile_A, 1) & "|" & arrAlt(Zeile_A, 2) & "|" _
& arrAlt(Zeile_A, 3)
Next
'Neue Meilensteine in Alt ergänzen
With wks_Alt
For Zeile_N = 3 To UBound(VergleichNeu)
Zeile = Application.Match(VergleichNeu(Zeile_N), VergleichAlt, 0)
If IsError(Zeile) Then 'neuer Meilenstein
varProjekt = arrNeu(Zeile_N, 3)
'Projekt in Projektspalte der Altdaten suchen
Set Zelle = .Range(.Cells(3, 4), .Cells(.Rows.Count, 4).End(xlUp)).Find( _
What:=varProjekt, LookIn:=xlValues, lookat:=xlWhole)
If Zelle Is Nothing Then 'neuesProjekt
Zeile = .Cells(.Rows.Count, 4).End(xlUp).Row + 1
Else
Zeile = Zelle.Row
Do
Zeile = Zeile + 1
If .Cells(Zeile, 4)  varProjekt Then
.Range(.Cells(Zeile, 4), .Cells(Zeile, 6)).Insert _
Shift:=xlShiftDown
Exit Do
End If
Loop
End If
.Cells(Zeile, 5) = arrNeu(Zeile_N, 2)
.Cells(Zeile, 6) = arrNeu(Zeile_N, 1)
With .Cells(Zeile, 4)
.Value = varProjekt
.Interior.ColorIndex = 3
End With
End If
Next
End With
'fehlende alte Meilensteine in Neu ergänzen
With wks_Neu
For Zeile_A = 3 To UBound(VergleichAlt)
Zeile = Application.Match(VergleichAlt(Zeile_A), VergleichNeu, 0)
If IsError(Zeile) Then 'fehlender Meilenstein
varProjekt = arrAlt(Zeile_A, 1)
'Projekt in Projektspalte der neuen Daten suhen
Set Zelle = .Range(.Cells(3, 3), .Cells(.Rows.Count, 3).End(xlUp)).Find( _
What:=varProjekt, LookIn:=xlValues, lookat:=xlWhole)
If Zelle Is Nothing Then ' fehlendes Projekt
Zeile = .Cells(.Rows.Count, 3).End(xlUp).Row + 1
Else
Zeile = Zelle.Row
Do
Zeile = Zeile + 1
If .Cells(Zeile, 3)  varProjekt Then
.Range(.Cells(Zeile, 1), .Cells(Zeile, 3)).Insert _
Shift:=xlShiftDown
Exit Do
End If
Loop
End If
.Cells(Zeile, 1) = arrAlt(Zeile_A, 3)
.Cells(Zeile, 2) = arrAlt(Zeile_A, 2)
With .Cells(Zeile, 3)
.Value = varProjekt
.Interior.ColorIndex = 3
End With
End If
Next
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Anzeige
AW: Tabellen vergleichen und anpassen (mit xlShiftDown
14.02.2018 18:20:36
Jaci
Hey Franz,
Nice. Funktioniert einwandfrei...
Jedoch habe ich das Problem, dass ich tatsächlich nur die Projekte angepasst haben möchte ( also ohne entsprechende Einfügungen der anderen Spalten bzw. Werte)
Es soll also nur Bezug auf die Projekte ( Spalte C und D ) genommen werden.
Geht das?
Gruß,
Jaci
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

Anzeige

302 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige