AW: @ FCS - kleine Rückfrage:
23.02.2009 18:37:14
fcs
Hallo Jessi,
hier eine Anpassung, die den Namen der Station beim Vergleich der Codes mit einbezieht und zum Schluss die Daten nach der Station sortiert.
Gruß
Franz
Sub CodeVergleich_var01()
Dim wksT As Worksheet, wksP As Worksheet, wksV As Worksheet
Dim lngZei As Long, lngZei_V As Long, lngZei_Titel_V As Long
Dim rngZelle2 As Range, arrSpalten, lngSpV As Long
Dim varCode, intI As Integer, bolIdentisch As Boolean, strAdresse1 As String
Dim rngBereich As Range, strStation As String, bolTreffer As Boolean
Dim lfdNr As Long
Const lngSpCode& = 2 'Spalte mit den Codes
Const lngTitel& = 9 'Zeile mit Spaltentiteln
Const lngAnz& = 8 'Anzahl Datenspalten in Tabellen (A bis H)
arrSpalten = Array(4, 5, 6, 7) 'Nummern der zu Vergleichenden Spalten (D, E, F, G)
Set wksT = Worksheets("Tender Figures")
Set wksP = Worksheets("VO Proposal")
'Neues Blatt für Datenvergleich anlegen
With ActiveWorkbook
.Worksheets.Add after:=.Sheets(.Sheets.Count)
End With
Set wksV = ActiveSheet
wksV.Name = "VO Analysis" & Format(Now, "YYYYMMDD_hhmmss")
'Titelzeilen in Vergleichstabele erzeugen
With wksV
lngZei_V = 0
lngZei_V = lngZei_V + 1
.Cells(lngZei_V, 1) = " Vergleich Codes in Tabellen"
lngZei_V = lngZei_V + 1
lngSpV = 1
.Cells(lngZei_V, lngSpV) = "lfd. Nr."
lngSpV = lngSpV + 1
.Cells(lngZei_V, lngSpV) = "Sheet"
'Spalten-Titel kopieren
lngSpV = lngSpV + 1
wksT.Range(wksT.Cells(lngTitel, 1), wksT.Cells(lngTitel, lngAnz)).Copy _
Destination:=.Cells(lngZei_V, lngSpV)
lngSpV = lngSpV + lngAnz
.Cells(lngZei_V, lngSpV) = "Kennz."
lngSpV = lngSpV + 1
.Cells(lngZei_V, lngSpV) = "SummeNeu"
lngZei_Titel_V = lngZei_V
End With
'Tabelle unter Titelzeilen fixieren
Cells(lngZei_V + 1, 1).Select
ActiveWindow.FreezePanes = True
'Codes in Tender im Proposal suchen
lfdNr = -1
'Suchbereich für Codes im Blatt Proposal
With wksP
Set rngBereich = .Range(.Cells(lngTitel + 1, lngSpCode), .Cells(.Rows.Count, lngSpCode).End( _
xlUp))
End With
With wksT
For lngZei = lngTitel + 1 To .Cells(.Rows.Count, lngSpCode).End(xlUp).Row
lfdNr = lfdNr + 2
varCode = .Cells(lngZei, lngSpCode).Value
strStation = .Cells(lngZei, lngSpCode - 1).Value
lngZei_V = lngZei_V + 1
'Laufende Nummer eintragen
lngSpV = 1
wksV.Cells(lngZei_V, lngSpV) = lfdNr
wksV.Cells(lngZei_V + 1, lngSpV) = lfdNr + 1
'Tabellennamen eintragen
lngSpV = lngSpV + 1
wksV.Cells(lngZei_V, lngSpV) = wksT.Name
wksV.Cells(lngZei_V + 1, lngSpV) = wksP.Name
'Code in Proposal suchen
Set rngZelle2 = wksP.Columns(lngSpCode).Find(What:=varCode, LookIn:=xlValues, _
lookat:=xlWhole)
If rngZelle2 Is Nothing Then
'Tender Code fehlt in Proposal
lngSpV = lngSpV + 1
'Daten kopieren
wksT.Range(wksT.Cells(lngZei, 1), wksT.Cells(lngZei, lngAnz)).Copy _
Destination:=wksV.Cells(lngZei_V, lngSpV)
wksV.Cells(lngZei_V + 1, 4) = varCode
wksV.Cells(lngZei_V + 1, 3) = strStation
'Datenzeile kennzeichen
lngSpV = lngSpV + lngAnz
wksV.Cells(lngZei_V, lngSpV).Value = "T"
'Summenformel eintragen
With wksV
lngSpV = lngSpV + 1
.Cells(lngZei_V, lngSpV).Formula = "=R[0]C[-3]"
End With
Else
strAdresse1 = rngZelle2.Address
bolTreffer = False
Do
If strStation = rngZelle2.Offset(0, -1).Value Then
bolTreffer = True
Exit Do
End If
Set rngZelle2 = rngBereich.FindNext(after:=rngZelle2)
If rngZelle2.Address = strAdresse1 Then Exit Do
Loop
lngSpV = lngSpV + 1
If bolTreffer = True Then
'Daten kopieren
wksT.Range(wksT.Cells(lngZei, 1), wksT.Cells(lngZei, lngAnz)).Copy _
Destination:=wksV.Cells(lngZei_V, lngSpV)
wksP.Range(wksP.Cells(rngZelle2.Row, 1), wksP.Cells(rngZelle2.Row, lngAnz)).Copy _
Destination:=wksV.Cells(lngZei_V + 1, lngSpV)
bolIdentisch = True
'Daten vergleichen
For intI = LBound(arrSpalten) To UBound(arrSpalten)
'Vergleich der Werte zwischen Tabellen
If wksT.Cells(lngZei, arrSpalten(intI)).Value _
wksP.Cells(rngZelle2.Row, arrSpalten(intI)).Value Then
bolIdentisch = False
wksV.Cells(lngZei_V + 1, lngSpV + arrSpalten(intI) - 1).Interior.ColorIndex = 3
End If
Next
'Datenzeile kennzeichen
lngSpV = lngSpV + lngAnz
If bolIdentisch = True Then
wksV.Cells(lngZei_V, lngSpV).Value = "T+P"
wksV.Cells(lngZei_V + 1, lngSpV).Value = "T+P"
Else
wksV.Cells(lngZei_V, lngSpV).Value = "T+P"
wksV.Cells(lngZei_V + 1, lngSpV).Value = "T+P"
End If
'Summenformel eintragen
With wksV
lngSpV = lngSpV + 1
.Cells(lngZei_V, lngSpV).Formula = "=R[0]C[-3]+R[1]C[-3]"
End With
Else
'Tender Code gibt es für die Station im Proposal nicht
lngSpV = lngSpV + 1
'Daten kopieren
wksT.Range(wksT.Cells(lngZei, 1), wksT.Cells(lngZei, lngAnz)).Copy _
Destination:=wksV.Cells(lngZei_V, lngSpV)
wksV.Cells(lngZei_V + 1, 4) = varCode
wksV.Cells(lngZei_V + 1, 3) = strStation
'Datenzeile kennzeichen
lngSpV = lngSpV + lngAnz
wksV.Cells(lngZei_V, lngSpV).Value = "T"
'Summenformel eintragen
With wksV
lngSpV = lngSpV + 1
.Cells(lngZei_V, lngSpV).Formula = "=R[0]C[-3]"
End With
End If
End If
lngZei_V = lngZei_V + 1
Next
End With
'Gegenprüfung Codes in Proposal im Tender suchen
With wksP
For lngZei = lngTitel + 1 To .Cells(.Rows.Count, lngSpCode).End(xlUp).Row
varCode = .Cells(lngZei, lngSpCode).Value
strStation = .Cells(lngZei, lngSpCode - 1).Value
'Code in Tender suchen
Set rngZelle2 = wksT.Columns(lngSpCode).Find(What:=varCode, LookIn:=xlValues, _
lookat:=xlWhole)
If rngZelle2 Is Nothing Then
'Proposal Code fehlt in Tender-Tabelle
bolTreffer = False
Else
strAdresse1 = rngZelle2.Address
bolTreffer = False
Do
If strStation = rngZelle2.Offset(0, -1).Value Then
bolTreffer = True
Exit Do
End If
Set rngZelle2 = rngBereich.FindNext(after:=rngZelle2)
If rngZelle2.Address = strAdresse1 Then Exit Do
Loop
End If
If bolTreffer = True Then
'Nichts eintragen, Daten sind bereits beim vorherigen Vergleich erfasst.
Else
'Proposal Code gibt es für die Station im Tender nicht
lfdNr = lfdNr + 2
lngZei_V = lngZei_V + 1
lngSpV = 1
wksV.Cells(lngZei_V, lngSpV) = lfdNr
wksV.Cells(lngZei_V + 1, lngSpV) = lfdNr + 1
lngSpV = lngSpV + 1
wksV.Cells(lngZei_V, lngSpV) = wksT.Name
wksV.Cells(lngZei_V + 1, lngSpV) = wksP.Name
lngSpV = lngSpV + 1
'Daten kopieren
wksV.Cells(lngZei_V, 4) = varCode
wksV.Cells(lngZei_V, 3) = strStation
wksP.Range(wksP.Cells(lngZei, 1), wksP.Cells(lngZei, lngAnz)).Copy _
Destination:=wksV.Cells(lngZei_V + 1, lngSpV)
'Datenzeile kennzeichen
lngSpV = lngSpV + lngAnz
wksV.Cells(lngZei_V + 1, lngSpV).Value = "P"
'Summenformel eintragen
With wksV
lngSpV = lngSpV + 1
.Cells(lngZei_V + 1, lngSpV).Formula = "=R[0]C[-3]"
End With
lngZei_V = lngZei_V + 1
End If
Next
End With
'Spalten in Zieltabelle formatieren
With wksV
.Cells.VerticalAlignment = xlVAlignTop
.UsedRange.EntireColumn.AutoFit
.Columns(1).ColumnWidth = 6
.Columns(5).ColumnWidth = 45
.Columns(5).WrapText = True
'sortieren nach Station und lfd. Nr.
Set rngBereich = .Range(.Rows(lngZei_Titel_V), .Rows(lngZei_V))
With rngBereich
.Sort key1:=.Range("C1"), order1:=xlAscending, _
key2:=.Range("A1"), order2:=xlAscending, header:=xlYes, Orientation:=xlTopToBottom
End With
'Spalte A neu nummerieren
lfdNr = 0
For lngZei = lngZei_Titel_V + 1 To lngZei_V Step 2
lfdNr = lfdNr + 1
.Cells(lngZei, 1).Value = lfdNr
.Cells(lngZei + 1, 1).Value = lfdNr
Next
End With
Set wksT = Nothing: Set wksP = Nothing: Set wksV = Nothing: Set rngZelle2 = Nothing
End Sub