Kompliziertes macro gesucht....

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox


Excel-Version: 10.0 (Office XP)
nach unten

Betrifft: Kompliziertes macro gesucht....
von: Florian
Geschrieben am: 16.07.2002 - 07:20:45

Es muss mir doch irgendwer helfen koennen!
Habe folgendes Problem.
Eine Tabelle mit 11 Spalten und rund 700 Zeilen.
Bsp.:
ABC Produkt Farbe Umsatz Lager ....
B Zahnrad blau 4000 200
C Scheibe rot 2000 100
A Mutter blau 5000 300
:
:

Mein Problem ist jetzt das ich jedes Produkt mit dem gleichen Eintrag der Farbe zusammenfassen will (alle EIntraege addieren).
Und zwar sollen die Zeilen von UNTEN nach OBEN zusammengefasst werden und dabei die ZU ADDIERENDE Zeile GELOESCHT werden!
Alle gleichen Farben werden also addiert. Und zwar von unten nach oben. Dabei wird der addierte Datensatz gelöscht.
Das sollte dann so aussehen:
ABC Produkt Farbe Umsatz Lager ...
B Zahnrad blau 9000 500
C Scheibe rot 2000 100
:
:
Ich suche schon seit Wochen nach eine Loesung, weil es natuerlich sehr muehsam ist das per Hand zu machen.
Es muss ueber ein Makro laufen, das ist mir schon klar.
Dabei ergibt sich natürlich ein weiteres Problem:
Es stehen ja nicht in jeder Zeile nur Zahlen. In "ABC" steht ja Text. Es soll dann so sein, das der erste Datensatz den Ton angibt, und die zu 'addierenden' Daten ignoriert werden!
Fuer mich ist das wirklich wichtig, ich wuerde mich wirklich freuen wenn mir da jemand weiter helfen kann!
(vielleich sind hierbei Hans oder Hajo gefragt?? ;) )
Aller Besten Dank im Voraus an alle mit Mitleid im Board!
Thx
Florian

nach oben   nach unten

Rückfrage
von: MikeS
Geschrieben am: 16.07.2002 - 07:38:52

Hi Florian,

Du willst jeden Artikel mit der gleichen Farbe addieren und den addierten
Datensatz löschen.

Warum sollen alle Zeilen von unten nach oben addiert werden?

Wie meinst Du das mit:

„Dabei ergibt sich ein weiteres Problem:
Es stehen ja nicht in jeder Zeile nur Zahlen. In ABC steht ja Text“ ???

Bitte nochmal erklären und ggfs. die Datei mir mal mailen.

Ciao MikeS

nach oben   nach unten

Code
von: MikeS
Geschrieben am: 16.07.2002 - 16:11:21

Hi Florian,

da ich keine Erklärung wegen ABC von Dir erhielt,
habe ich einfach mal so probiert...

Der Code (Bereich muß noch angepaßt werden)


Option Explicit

Sub SortierenSummierenEliminieren()
  Dim Sortierbereich As Range
  Dim lSum As Long
  Dim lRow As Long
  Dim Zelle As Range
  Set Sortierbereich = Range("A2:K31") 'Überschrift steht in A1:K1
  lRow = 2
  Application.ScreenUpdating = False
       
    ' Bereich sortieren nach Produkt, Farbe und Lager
    Sortierbereich.Select
    Selection.Sort Key1:=Range("B2"), _
    Order1:=xlAscending, Key2:=Range("C2"), _
    Order2:=xlAscending, Key3:=Range("E2"), _
    Order3:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
  
    Range("B2").Select
    
    'Zellen darunter prüfen
    Do Until lRow > ActiveSheet.UsedRange.Rows.Count
      If Cells(lRow, 2) = Cells(lRow + 1, 2) And _
        Cells(lRow, 3) = Cells(lRow + 1, 3) And _
        Cells(lRow, 5) = Cells(lRow + 1, 5) _
      Then
        lSum = Cells(lRow, 4) + Cells(lRow + 1, 4)  'Summe erweitern
        ActiveCell.Offset(0, 2).Value = lSum          'in Zelle schreiben
        ActiveCell.Offset(1, 0).EntireRow.Delete    'Zeile darunter löschen
      Else
        ActiveCell.Offset(1, 0).Select  'Zelle eins tiefer
        lRow = lRow + 1                   'Zähler erhöhen
      End If
    Loop
  Application.ScreenUpdating = True
End Sub

Ciao MikeS

nach oben   nach unten

Lösung
von: Martin M.
Geschrieben am: 16.07.2002 - 17:17:05

Hallo Florian,
das hier müsste deinen Wünschen entsprechen:

Sub Summieren()
  '- Dieses Makro muß in dem Tabellenblatt aufgerufen werden, das
  '  die auszuwertenden Daten enthält.
  '- Im Makro muß die Nummer der Spalte angegeben werden, welche die
  '  Farbe enthält. (Variable SF)
  '- Bei der Sortierung wird vorausgesetzt, daß in der ersten Zeile
  '  die Überschrift steht.
  '- Die Zeile 1 darf im Datenbereich keine leeren Zellen enthalten.
  '- Die Spalte A darf im Datenbereich keine leeren Zellen enthalten.
  
  Dim Zeilen
  Dim Spalten As Integer
  Dim Zellwert As Variant
  Dim SF As Integer
  Dim ws As Worksheet
  
  Application.ScreenUpdating = False
  
  'Nummer der Spalte, welche die Farbe enthält
  SF = 3
  
  'Aktives Tabellenblatt kopieren und die Kopie auswerten
  ActiveSheet.Copy
  Set ws = ActiveSheet
    
  'Anzahl der Zeilen und Spalten ermitteln
  Zeilen = ws.Cells(1, 1).End(xlDown).Row
  Spalten = ws.Cells(1, 1).End(xlToRight).Column

  'Hilfsspalte einfügen und nummerieren
  Columns("A:A").Insert Shift:=xlToRight
  Dim As Long
  For i = 1 To Zeilen
    Cells(i, 1) = i
  Next i
  
  'Durch die Hilfsspalte verschiebt sich die Spalte mit der Farbe
  SF = SF + 1
  
  'Nach Farbe sortieren
  ws.Cells(1, 1).Sort Key1:=Cells(2, SF), Order1:=xlAscending, Key2:=Range("A2") _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom

  'Von unten alle Zeilen durchgehen und summieren
  Dim As Long 'Zeile
  Dim As Integer 'Spalte
  For Z = Zeilen To Step -1
    'Wenn Zeile die gleiche Farbe wie Zeile-1 hat wird summiert
    If Cells(Z, SF) = Cells(Z - 1, SF) Then
      'Für alle Spalten im Datenbereich:
      'Zeile und Zeile-1 werden Summiert und in Zeile-1 geschrieben.
      For S = 2 To Spalten + 1
        'Die Summe wird nur gemacht, wenn Wert numerisch ist
        If IsNumeric(Cells(Z, S)) And IsNumeric(Cells(Z - 1, S)) Then
          Cells(Z - 1, S) = Cells(Z, S) + Cells(Z - 1, S)
        End If
      Next S
      'Nachdem in allen Spalten Zeile und Zeile-1 summiert wurde,
      'wird Zeile gelöscht.
      Cells(Z, 1).EntireRow.Delete
    End If
  Next Z
  
  'Wieder nach ursprünglicher Reihenfolge sortieren
  ws.Cells(1, 1).Sort Key1:=Cells(1, 1), Order1:=xlAscending, Key2:=Cells(1, 1) _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom
  
  'Hilfsspalte löschen
  Cells(1, 1).EntireColumn.Delete

  ws.Cells(1, 1).Activate
  Application.ScreenUpdating = True
  MsgBox "Die Auswertung ist beendet.", vbInformation, "Auswertung nach Farbe"
End Sub

Grüße
Martin M.

 nach oben

Beiträge aus den Excel-Beispielen zum Thema "excel problem"