Hallo zusammen,
ich habe folgendes Problem. Ich muss aus in Exceltabelle die doppelten Einträge suchen und die Mengen zusammen rechnen. Das Ergebnis soll dann unter dem Suchkreterium in einer neuen Tabelle einmal ausgegeben werden. Ich habe folgenden Code:
Private Sub DoppelteElemente1()
Dim s As String
Dim ergebnis As Integer
Dim zelle(100) As String
Dim zel As Integer
Sheets("Tabelle1").Activate
Do Until Range("A1").Value = ""
artikel = Range("a1").Value
Range("a1").Select
i = 0
s = Range("a1").Value
ergebnis = 0
Do Until ActiveCell.Value = ""
If InStr(ActiveCell.Value, s) > 0 Then
ergebnis = ergebnis + ActiveCell.Offset(0, 2).Value
zelle(i) = ActiveCell.Address
i = i + 1
MsgBox i
End If
ActiveCell.Offset(1, 0).Select
Loop
For z = 0 To i - 1
Range(zelle(z)).EntireRow.Delete Shift:=x1Up
Next z
Sheets("Tabelle2").Activate
Range("A1").Select
ActiveCell.Offset(zel, 0).Value = artikel
ActiveCell.Offset(zel, 1).Value = ergebnis
zel = zel + 1
Sheets("Tabelle1").Activate
Loop
End Sub
Das Funtioniert eigentlich ganz gut, bis auf das er mir immernoch Einträge doppelt in die neue Tabelle schreibt. Leider komme ich nicht weiter. Vieleicht könnt Ihr mir helfen. Danke im Vorraus. |