Zusammenführen von Datensätzen funtioniert nicht
06.02.2009 12:14:00
Datensätzen
habe mal wieder ein schwieriges Problem.
Ich habe ein Tabellenblatt, mit vielen Datensätzen. IN der Spalte B sind zu jeden Datensatz ID's eingetragen. NUn kann es vorkommen, dass es in der Spalte B Datensätze mit der Gleicher ID gibt.
Dabei soll der Code alle Datensätze durchlaufen, bei doppelt vorkommende datzensätzen (ID) soll der Code aus den Spalten L, S, AB, BB, BK die Preis dem ersten datensatz alle aufaddieren und soll dann die mehrfach vorkommenden Datensätze löschen, dass am Schluss von jeder ID nur noch einer mit den Gesamtsummen dasteht.
Das klappt auch soweit, bis auf dieses Problem: wenn ich den Code dann so ausführe, wird in der Spalte AP auch eine addition durchgeführt, obwohl AP nirgends angesprochen wird.
Ich bin dahinter gekommen, wenn man im Code die Zeile
'wks.Cells(intR, ColAB).Value = wks.Cells(intR, ColAB).Value + Left$(wks.Cells(intAR, ColAB).Value, 10)
deaktiviert, wierd in AP auch keine Addition duchgeführt. Das verstehe ich nicht, was hat denn hier AB mit AP zu tun ?
Kann jemand irgend wie einen Fehler finden ?
Hier mal der Code
Danke
Application.ScreenUpdating = False
Dim x As Long
For x = 1 To Worksheets.Count
Next
Worksheets.Add.Name = "deleted data"
Worksheets("gelöscht").Move After:=Sheets(Worksheets.Count)
Sheets("data").Select
Dim wks As Worksheet
' Zeilenvariablen definieren .
Dim intAR As Integer
Dim intFR As Integer
Dim intLR As Integer
Dim intR As Integer
Dim strSuchtext As String
Dim rngSuchBereich As Range
' benötigte Spaltenkonstanten bestimmen .
Const ColB As Integer = 2
Const ColL As Integer = 12
Const ColP As Integer = 16
Const ColS As Integer = 19
Const ColAB As Integer = 42
Const ColBB As Integer = 54
Const ColBK As Integer = 63
' Aktives Tabellenblatt definieren .
Set wks = ActiveWorkbook.Sheets("data")
' Letzte Zeile ermitteln .
intFR = 10
intLR = wks.UsedRange.Rows.Count
' Zeilendurchlauf .
For intR = intFR To intLR
'strSuchtext = wks.Cells(intR, ColB)
strSuchtext = Left(wks.Cells(intR, ColB), 10) & "*"
If strSuchtext GRÖSSER "" Then
Set rngSuchBereich = wks.Range(Cells(intR + 1, ColB), Cells(intLR, ColB))
' weiterer Eintrag vorhanden? .
While WorksheetFunction.CountIf(rngSuchBereich, strSuchtext) GRÖSSER 0
intAR = WorksheetFunction.Match(strSuchtext, rngSuchBereich, 0)
intAR = intR + intAR
' 1. Eintrag aktualisieren .
' Addition
wks.Cells(intR, ColL).Value = wks.Cells(intR, ColL).Value + Left$(wks.Cells(intAR, ColL).Value, 10)
wks.Cells(intR, ColS).Value = wks.Cells(intR, ColS).Value + Left$(wks.Cells(intAR, ColS).Value, 10)
'wks.Cells(intR, ColAB).Value = wks.Cells(intR, ColAB).Value + Left$(wks.Cells(intAR, ColAB).Value, 10) ##############
wks.Cells(intR, ColBB).Value = wks.Cells(intR, ColBB).Value + Left$(wks.Cells(intAR, ColBB).Value, 10)
wks.Cells(intR, ColBK).Value = wks.Cells(intR, ColBK).Value + Left$(wks.Cells(intAR, ColBK).Value, 10)
' Text
wks.Cells(intR, ColP).Value = wks.Cells(intR, ColP).Value & " +++ " & wks.Cells(intAR, ColP).Value
' 2. Eintrag löschen
Debug.Print Cells(Rows.Count, 2).End(xlUp).Address
Debug.Print Sheets("gelöscht").Cells(Rows.Count, 2).End(xlUp).Address
Rows(intAR).Copy _
Sheets("gelöscht").Cells(Rows.Count, 2).End(xlUp).Offset(1, -1)
'Rows(intAR).Font.ColorIndex = 3
Rows(intAR).Delete Shift:=xlUp
intLR = intLR - 1
Wend
End If
Next intR