Verdichtung einer Tabelle
23.07.2003 12:13:27
Bluebeagle
folgendes VBA-Skript (Original von Nike, danke nochmal) soll eine Excel-Tabelle komprimieren um mehrfach Informationen zu löschen.
In der Ausgangstabelle existiert pro Attribut (Att1....Att3) und ID jeweils eine Zeile. In der komprimierten Tabelle soll dann nur noch eine Zeile pro ID vorhanden sein und die Attribute nebeneinander gelistet werden, sofern vorhanden. Überzählige Zeilen werden gelöscht.
Soweit so gut, die überflüssigen Zeilen werden gelöscht, aber die Spalten mit Attributen werden komplett gefüllt/markiert und nicht nur dort wo das entsprechende Attribut auch wirklich vorhanden wahr.
Meine Frage nun was habe ich falsch gemacht? Ich sehe wahrscheinlich den Wald vor lauter Bäumen nicht.
Vielen Dank für Eure Hilfe im voraus und ich hoffe dass ich bald in der Lage bin auch zu helfen und nicht nur Hilfe zu empfangen.
Gruss
bluebeagle
Sub reduceDB()
Dim lngRow As Long
For lngRow = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If Cells(lngRow, 1) = strLand And _
Cells(lngRow, 2) = strFirma And _
Cells(lngRow, 3) = strName And _
Cells(lngRow, 4) = strID Then
If Cells(lngRow, 6) <> "" Then
strAtt1 = Cells(lngRow, 6)
End If
If Cells(lngRow, 7) <> "" Then
strAtt2 = Cells(lngRow, 7)
End If
If Cells(lngRow, 8) <> "" Then
strAtt3 = Cells(lngRow, 8)
End If
Rows(lngRow + 1).Delete
Else
strLand = Cells(lngRow, 1)
strFirma = Cells(lngRow, 2)
strName = Cells(lngRow, 3)
strID = Cells(lngRow, 4)
If lngRow <> Cells(Rows.Count, 1).End(xlUp).Row Then
Cells(lngRow + 1, 6) = strAtt1
Cells(lngRow + 1, 7) = strAtt2
Cells(lngRow + 1, 8) = strAtt3
End If
If Cells(lngRow, 6) <> "" Then
strAtt1 = Cells(lngRow, 6)
End If
If Cells(lngRow, 7) <> "" Then
strAtt2 = Cells(lngRow, 7)
End If
If Cells(lngRow, 8) <> "" Then
strAtt3 = Cells(lngRow, 8)
End If
End If
Next
Cells(lngRow + 1, 6) = strAtt1
Cells(lngRow + 1, 7) = strAtt2
Cells(lngRow + 1, 8) = strAtt3
End Sub