Guten Morgen,
ich komme nicht weiter mit meinem Programm. Brauche HIlfe .
Spalte A ist Datum, Spalte B ist Kunde, Spalte D ist Kosten.In Spalte C sollen die Kosten summiert der gleichen Kunde wie im Vormonat kommen.
Im ersten Monat soll der erste Kunde im Monat zwei gesucht werden.
Wenn gefunden, sollen die Kosten addiert und in Spalte C vom 2. Monat angezeigt werden.
Dann soll der nächste Kunde gesucht werden.
Wenn Kunde im ersten Monat nicht im zweiten Monat vorhanden ist, dann soll im 3. Monat und im 4. Monat gesucht werden.
Das gleiche dann mit dem 2. Monat
Der Kunde im 2. Monat soll im 3. Monat gesucht wertden. Wenn nicht vorhanden, dann im 4.Monat, wenn nicht, dann im 5. Monat, wenn nicht, dann im 6. Monat.
Also die Suche soll in den nächsten 4 Monaten sein.
Mein Programm sucht den Kunden im 1. Monat in allen Monaten. Wie kann ich dies begrenzen.
Vielen Dank
LG
A B C D
2010 03
aa 5
bb 2
cc 3
2010 04
ss 2
aa 4
cc 5
2010 05
bb 1
aa 2
2010 06
kk 2
aa 4
2010 07 kk 3
bb 1 Sub Neu()
Dim intSuche As Integer
Dim rngcell As Range
Dim rngcell2 As Range
Dim c As Range
Dim CompareRange As Variant, a As Variant, b As Variant
With ActiveSheet
'zählt bis nächsten Datum
lrow = .Cells(.Rows.Count, 1).End(xlUp).Row
l = 2
Do While Cells(l, 1).Value <> ","
'Suchwert festlegen (anpassen!):
Suche = "*"
Set rngcell = .Columns(1).Cells.Find(Suche, .Cells(lrow, 1), , xlWhole, , _
xlNext)
If Not rngcell Is Nothing Then 'wenn etwas gefunden wurde
xZahl = rngcell
On Error Resume Next
End If
arrSplit1 = Split(xZahl, " ")
If UBound(arrSplit1) >= 1 Then
bereichLft = arrSplit1(0)
bereichRgt = arrSplit1(1)
x = bereichLft & bereichRgt
End If
Set rngcell2 = .Columns(1).Cells.FindNext(rngcell)
yZahl = rngcell2
arrSplit2 = Split(yZahl, " ")
If UBound(arrSplit2) >= 1 Then
bereichLft = arrSplit2(0)
bereichRgt = arrSplit2(1)
y = bereichLft & bereichRgt
End If
If y - x = 1 Or y - x = 2 Or y - x = 3 Or y - x = 4 Then
For l = 1 To lrow
If m = lrow Then
Exit Sub
End If
If Cells(l, 1) = xZahl Or Cells(l, 1) = yZahl Then
'Zählt bis zum nächsten Datum
Nrows = Cells(l, 1).End(xlDown).Row
'Zählt bis zur letzten leere Zelle
Rnumber1 = Cells(Rows.Count, 2).End(xlUp).Row + 1
End If
For k = l + 1 To Nrows - 2
If .Sheets(1).Range("C" & k + 1) <> "" Then '+ 1
'CompareRange fester Suchwert
Set CompareRange = Range("B" & k)
End If
For m = Nrows + 1 To Rnumber1 - 1
'b ist fester gesuchte Wert
For Each b In CompareRange
Set a = Range("B" & m)
If a = b Then a.Offset(0, 1) = b.Offset(0, 2) + _
a.Offset(0, 2)
Exit For
Next b
If a = b Then
Exit For
End If
Next m
Next k
Next l
End If
'aufräumen:
Set rngcell = Nothing: Set rngcell2 = Nothing
Loop
End With
End Sub
Beitrag wurde zuletzt am 17.07.16 um 08:22:23 editiert. |