Microsoft Excel

Herbers Excel/VBA-Archiv

Addieren der doppelten Werte und anschliessend sor



Excel-Version: 10.0 (Office XP)

Betrifft: Addieren der doppelten Werte und anschliessend sor
von: Steve
Geschrieben am: 29.05.2002 - 21:02:13

Addieren der doppelten Werte und anschliessend sortieren.
Hallo,

Habe folgendes problem.
Möchte, dass die Werte die sich wie folgt in meiner Tabelle befinden
.......A | B
01/02 | 100
01/02 | 115
01/02 | 450
.........| ...
.........| ...
01/03 | 120
01/03 | 412
.........| ...
.........| ...
02/03 | 125
.........| ...
02/02 | 365
02/02 | 255
.........| ...
03/02 | 100
.........| ...
.........| ...
.........| ...

nach dem Ablauf eines Makros per Knpof wie folgt aussehen
A........| B
01/02 | 665
02/02 | 620
03/02 | 100
.........| ...
01/03 | 532
02/03 | 125
.........| ...

Bei den Werten bsp. "01/02" handelt es sich um "Monat/Jahr"
Die doppelten Werte von 01/02 werden addiert
" " " " 02/02 werden addiert
" " " " 01/03 werden addiert

und die Werte die nur einmal vorkommen dürfen nicht verändert werden.

Freue mich für jeden Vorschlag.
Danke im Voraus.
Steve.




  

Re: Addieren der doppelten Werte und anschliessend sor
von: WernerB.
Geschrieben am: 29.05.2002 - 22:17:33

Hallo Steve,

teste mal diesen Code:


Option Explicit
Sub Komprimieren()
Dim As Range
Dim za1 As String, za2 As String
Dim As Double
Dim As Long, j As Long, laR As Long
Dim farb As Boolean
    Application.ScreenUpdating = False
    laR = Cells(Rows.Count, 1).End(xlUp).Row
    za2 = Cells(laR, 1).Address(False, False)
    For i = 1 To laR
      za1 = Cells(i, 1).Address(False, False)
      w = 0
      farb = False
      For Each c In Range(za1 & ":" & za2)
        If c.Interior.ColorIndex <> 46 And c.Value = Cells(i, 1).Value Then
          c.Interior.ColorIndex = 46
          w = w + c.Offset(0, 1).Value
          farb = True
        End If
      Next c
      If farb = True Then
        Cells(i, 1).Interior.ColorIndex = 0
        Cells(i, 2).Value = w
      End If
    Next i
    For i = laR To Step -1
      If Cells(i, 1).Interior.ColorIndex = 46 Then _
        Cells(i, 1).EntireRow.Delete
    Next i
    Application.ScreenUpdating = True
End Sub

Viel Erfolg wünscht
WernerB.
  

Re: Addieren der doppelten Werte und anschliessend sor
von: Steve
Geschrieben am: 29.05.2002 - 23:01:04

Hi Werner,
Das mit dem Summieren klappt schon gut nur die Werte müssten noch folgendermassen sortiert werden:
A........| B
01/02 |100
02/02 |200
03/02 |120
04/02 |130
05/02 |450
06/02 |145
07/02 |453
08/02 |785
09/02 |369
10/02 |789
11/02 |782
12/02 |555
01/03 |789
02/03 |123
03/03 |369
.........|...
.........|...
12/03 |111
01/04 |123
02/04 |487
.........|...
.........|...

Wäre glücklich wenn wir das auch noch in den Griff bekommen.
Danke.
Steve
P.S. Starke Seite

  

Re: Addieren der doppelten Werte und anschliessend sor
von: WernerB.
Geschrieben am: 30.05.2002 - 00:15:15

Hallo Steve,

nun ergründe mal, ob "wir" das in den Griff bekommen haben, oder ob Deinem Glück noch etwas im Wege steht ...


Option Explicit
Sub Komprimieren()
Dim As Range
Dim za1 As String, za2 As String
Dim As Double
Dim As Long, j As Long, laR As Long
Dim farb As Boolean
    Application.ScreenUpdating = False
    laR = Cells(Rows.Count, 1).End(xlUp).Row
    za2 = Cells(laR, 1).Address(False, False)
    For i = 1 To laR
      za1 = Cells(i, 1).Address(False, False)
      w = 0
      farb = False
      For Each c In Range(za1 & ":" & za2)
        If c.Interior.ColorIndex <> 46 And c.Value = Cells(i, 1).Value Then
          c.Interior.ColorIndex = 46
          w = w + c.Offset(0, 1).Value
          farb = True
        End If
      Next c
      If farb = True Then
        Cells(i, 1).Interior.ColorIndex = 0
        Cells(i, 2).Value = w
        Cells(i, 3).Value = Left(Cells(i, 1).Value, 2)
        Cells(i, 4).Value = Right(Cells(i, 1).Value, 2)
      End If
    Next i
    For i = laR To Step -1
      If Cells(i, 1).Interior.ColorIndex = 46 Then _
        Cells(i, 1).EntireRow.Delete
    Next i
    laR = Cells(Rows.Count, 1).End(xlUp).Row
    Range("A1:D" & laR).Sort Key1:=Range("D1"), Order1:=xlAscending, _
      Key2:=Range("C1"), Order2:=xlAscending, Header:=xlGuess, _
      OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Range("C1:D" & laR).ClearContents
    Application.ScreenUpdating = True
    Range("A1").Select
End Sub

Viel Erfolg wünscht
WernerB.
  

Re: Addieren der doppelten Werte und anschliessend sor
von: Steve
Geschrieben am: 30.05.2002 - 00:34:07

Hi Werner,
möchte mich bei dir bedanken klappt super.
Danke
Steve

 

Beiträge aus den Excel-Beispielen zum Thema "Addieren der doppelten Werte und anschliessend sor"