Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

gleiche Zellen addieren, sortieren, und doppelte

Betrifft: gleiche Zellen addieren, sortieren, und doppelte von: Ron Dmc
Geschrieben am: 25.10.2014 12:54:14

Hallo zusammen,

ich hoffe hier kann mir geholfen werden!!!
Ich habe folgendes Problem:
ArtNr Stück
4260 1
4270 1
4257 1
4260 1
4257 1

Das Ergebnis sollte sein:
ArtNr Stück
4257 2
4260 2
4270 1

Ich weiss, dass dies mit einem Makro umzusetzen ist, doch leider fehlen mir die Kenntnisse.

Ich hoffe mir kann jemand helfen?
Vielen Dank vorab!!!

  

Betrifft: AW: gleiche Zellen addieren, sortieren, und doppelte von: Daniel
Geschrieben am: 25.10.2014 13:17:34

Hi

Du kannst die Daten mit einer Pivottabelle auswerten, dann werden sie so zusammen gefasst.
Wenn du eine normale Tabelle zum weiter Arbeiten brauchst, kannst du die Pivottabelle Kopierern und an gleicher oder anderer Stelle als wert einfügen.


Mit Formeln wird die Umwandlung etwas aufwendiger:

1. Tabelle nach Spalte A sortieren

2. In Zelle C2 die Formel: =B2+wenn(A2=A3;C2;0)
3. Im Zelle D2 die Formel: =wenn(A2=A1;1;"")
4. Beide Formeln bis ans Datenende ziehen

5. Die Spalten C:D kopieren und als wert einfügen

6. Mit dem Autofilter in Spalte D nach 1 filtern und diese Zeilen löschen.
Du kannst auch nach Spalte D sortieren, dann stehen alle Zellen die gelöscht werden müssen direkt untereinander, so dass du sie leicht selektieren kannst.

7. Lösche Spalten B und D.

Gruß Daniel


  

Betrifft: AW: gleiche Zellen addieren, sortieren, und doppelte von: Tino
Geschrieben am: 25.10.2014 13:18:16

Hallo,
hier mal ein Code mit dem Spezialfilter.

Sub Beispiel()
With Tabelle1 'Tabelle anpassen 
    .Range("D:E").ClearContents 'Ziel löschen 
    .Range("D1:E1").Value = .Range("A1:B1").Value 'Überschrift 
    
    .Columns(1).AdvancedFilter xlFilterCopy, , .Range("D1"), True 'Filter ohne doppelte 
    
    With .Range("D2", .Cells(.Rows.Count, 4).End(xlUp)).Resize(, 2) 'Ziel Bereich 
        'Formal =Summewenn(...) 
        .Columns(2).FormulaR1C1 = _
            "=SUMIF('" & .Parent.Name & "'!C1,'" & .Parent.Name & "'!RC[-1],'" & .Parent.Name & "'!C2)"
        'Formel durch Werte ersetzen 
        .Columns(2).Value = .Columns(2).Value
        'sortieren 
        .Sort .Cells(1, 1), Order1:=xlAscending, Header:=xlNo
    End With
End With
End Sub
Gruß Tino


  

Betrifft: AW: gleiche Zellen addieren, sortieren, und doppelte von: Ron Dmc
Geschrieben am: 25.10.2014 14:09:12

Vielen Dank für die schnelle Hilfe. Mit Pivot-Tabellen kenne ich mich noch nicht aus. (Werde ich aber mal versuchen)
Das Makro funktioniert schon ganz gut, folgende Dinge wären aber noch sinnvoll:
1. ArtNr. werder sortiert
2. Die Daten des Makros werden in Tabellenblatt2 gespeichert

Außerdem habe ich noch eine Frage.
Da die Eingabe der ArtNr. mit Hilfe eines EAN-Scanners passiert, wäre es schön, wenn das alles Live passieren würde.
Bedeutet: man scannt einen Code (13stellige Zahl) und sollte es der gleiche sein, wird die Sückzahl automatisch um 1 erhöht. Ist soetwas mit Excel eigentlich umzusetzen?

Vielen Dank Vorab.


  

Betrifft: AW: gleiche Zellen addieren, sortieren, und doppelte von: Tino
Geschrieben am: 25.10.2014 14:57:23

Hallo,
hier mal ein Beispiel.

Code steht in Tabelle1 (Worksheet_Change) und in Modul1 (Daten_Verarbeiten)
https://www.herber.de/bbs/user/93364.xlsm


Gruß Tino


  

Betrifft: AW: gleiche Zellen addieren, sortieren, und doppelte von: Ron Dmc
Geschrieben am: 25.10.2014 15:30:30

Hallo Tino,
Weltklasse!!!
Vielen Dank. funktioniert genau so wie ich es mir vorgestellt habe.
Jetzt habe ich noch eine Frage, in meiner Datei https://www.herber.de/bbs/user/93365.xls gibt es einen Datei Kopf und zusätzlich Einträge wie in Zeile 85/86. Kann man diese auch in Tabelle2 übernehmen? Und wenn ja wie?
Viele Grüße und tausend Dank.


  

Betrifft: etwas komplizierter, aber lösbar von: Tino
Geschrieben am: 25.10.2014 18:53:55

Hallo,
dann wird es etwas komplizierter.
Schau mal ob es so geht?!

https://www.herber.de/bbs/user/93369.xlsm

Gruß Tino


  

Betrifft: in deiner Liste ist ganz unten noch eine Tabelle von: Tino
Geschrieben am: 26.10.2014 11:18:49

Hallo,
die habe ich gar nicht gesehen.

Ersetze den kompletten Code in Modul1 durch diesen.

Option Explicit

Sub Daten_Verarbeiten(WBQuelle As Worksheet, WBZiel As Worksheet)
Dim ArData
Dim nMinRow, MaxRow&, n&
Dim oDic As Object

Const Suchwort$ = "Artikelnum"
Const OffsetTabAnfang& = -1

On Error GoTo ErrorHandler:

With Tabelle1
    nMinRow = Application.Match(Suchwort & "*", .Columns(1), 0)
    nMinRow = nMinRow + OffsetTabAnfang
    MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    ArData = .Range(.Cells(nMinRow, 1), .Cells(MaxRow, 2))
End With

'nMinRow = 16 

With Tabelle2
    .Range("A16", .Cells(.Rows.Count, 2)).Clear
    For n = 1 To Ubound(ArData) + OffsetTabAnfang
        If InStr(ArData(n - OffsetTabAnfang, 1), Suchwort) > 0 Or (n = Ubound(ArData) + OffsetTabAnfang) Then
            If Not oDic Is Nothing Then
                If oDic.Count > 0 Then
                    With .Cells(nMinRow, 1).Resize(oDic.Count).Resize(, 2)
                        .Columns(1).NumberFormat = "0"
                        .Columns(1).Value = Application.Transpose(oDic.keys)
                        .Columns(2).Value = Application.Transpose(oDic.items)
                        With .Rows(2).Resize(.Rows.Count)
                            .Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlYes
                            nMinRow = .Rows(.Rows.Count).Row + 1
                        End With
                        With .Rows(1).Resize(2)
                            .Font.Bold = True
                            .Font.Size = 12
                            .Rows(2).Interior.Color = RGB(192, 192, 192)
                        End With
                    End With
                    
                End If
            End If
            Set oDic = Nothing
            Set oDic = CreateObject("Scripting.Dictionary")
        End If
        If IsNumeric(ArData(n, 2)) And ArData(n, 2) <> "" Then
            oDic(ArData(n, 1)) = oDic(ArData(n, 1)) + ArData(n, 2)
        Else
            oDic(ArData(n, 1)) = ArData(n, 2)
        End If
    Next n
End With
Exit Sub
ErrorHandler:
    MsgBox Err.Description, _
           vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
           "Error: " & Err.Number, Err.HelpFile, Err.HelpContext
End Sub
Gruß Tino


  

Betrifft: AW: in deiner Liste ist ganz unten noch eine Tabelle von: Ron Dmc
Geschrieben am: 27.10.2014 09:08:01

Super, genial!!!
Funktioniert richtig gut. Vielen Dank.
Ist es möglich in Tabelle2 ebenfals noch die Spalten C und D abzubilden?

Viele Grüße Ron


  

Betrifft: AW: in deiner Liste ist ganz unten noch eine Tabelle von: Tino
Geschrieben am: 27.10.2014 17:24:39

Hallo,
ges. Code wieder ersetzen!

Option Explicit

Sub Daten_Verarbeiten(WBQuelle As Worksheet, WBZiel As Worksheet)
Dim ArData
Dim nMinRow, MaxRow&, n&
Dim oDic As Object, ODicBrutto As Object, oDicGes As Object

Const Suchwort$ = "Artikelnum"
Const OffsetTabAnfang& = -1

On Error GoTo ErrorHandler:

With Tabelle1
    nMinRow = Application.Match(Suchwort & "*", .Columns(1), 0)
    nMinRow = nMinRow + OffsetTabAnfang
    MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    ArData = .Range(.Cells(nMinRow, 1), .Cells(MaxRow, 4))
End With

'nMinRow = 16 

With Tabelle2
    .Range("A16", .Cells(.Rows.Count, 4)).Clear
    For n = 1 To Ubound(ArData) + OffsetTabAnfang
        If InStr(ArData(n - OffsetTabAnfang, 1), Suchwort) > 0 Or (n = Ubound(ArData) + OffsetTabAnfang) Then
            If Not oDic Is Nothing Then
                If oDic.Count > 0 Then
                    With .Cells(nMinRow, 1).Resize(oDic.Count).Resize(, 4)
                        .Columns(1).NumberFormat = "0"
                        .Columns(1).Value = Application.Transpose(oDic.keys)
                        .Columns(2).Value = Application.Transpose(oDic.items)
                        .Columns(3).NumberFormat = "#,##0.00 $"
                        .Columns(3).Value = Application.Transpose(ODicBrutto.items)
                        .Columns(4).NumberFormat = "#,##0.00 $"
                        .Columns(4).Value = Application.Transpose(oDicGes.items)
                        With .Rows(2).Resize(.Rows.Count)
                            .Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlYes
                            nMinRow = .Rows(.Rows.Count).Row + 1
                        End With
                        With .Rows(1).Resize(2)
                            .Font.Bold = True
                            .Font.Size = 12
                            .Rows(2).Interior.Color = RGB(192, 192, 192)
                        End With
                    End With
                    
                End If
            End If
            Set oDic = Nothing
            Set oDic = CreateObject("Scripting.Dictionary")
            Set ODicBrutto = Nothing
            Set ODicBrutto = CreateObject("Scripting.Dictionary")
            Set oDicGes = Nothing
            Set oDicGes = CreateObject("Scripting.Dictionary")
        End If
        If IsNumeric(ArData(n, 2)) And ArData(n, 2) <> "" Then
            oDic(ArData(n, 1)) = oDic(ArData(n, 1)) + IIf(IsError(ArData(n, 2)), 0, ArData(n, 2))
            ODicBrutto(ArData(n, 1)) = ODicBrutto(ArData(n, 1)) + IIf(IsError(ArData(n, 3)), 0, ArData(n, 3))
            oDicGes(ArData(n, 1)) = oDicGes(ArData(n, 1)) + IIf(IsError(ArData(n, 4)), 0, ArData(n, 4))
        Else
            oDic(ArData(n, 1)) = IIf(IsError(ArData(n, 2)), 0, ArData(n, 2))
            ODicBrutto(ArData(n, 1)) = IIf(IsError(ArData(n, 3)), 0, ArData(n, 3))
            oDicGes(ArData(n, 1)) = IIf(IsError(ArData(n, 4)), 0, ArData(n, 4))
        End If
    Next n
End With
Exit Sub
ErrorHandler:
    MsgBox Err.Description, _
           vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
           "Error: " & Err.Number, Err.HelpFile, Err.HelpContext
End Sub
Gruß Tino


  

Betrifft: AW: in deiner Liste ist ganz unten noch eine Tabelle von: Ron Dmc
Geschrieben am: 28.10.2014 08:18:23

Hallo Tino,

funktioniert fast!Spalte C soll nur der Wert übergeben werden, auf dem der Verweis liegt. Spalte D soll dann berechnet werden B*C.

Danke vorab.

Gruß Ron


  

Betrifft: AW: in deiner Liste ist ganz unten noch eine Tabelle von: Tino
Geschrieben am: 28.10.2014 14:57:40

Hallo,
mach aus der Zeile

.Columns(4).Value = Application.Transpose(oDicGes.items)

diese
.Columns(4).FormulaR1C1 = Application.Transpose(oDicGes.items)

und aus der Zeile
oDicGes(ArData(n, 1)) = oDicGes(ArData(n, 1)) + IIf(IsError(ArData(n, 4)), 0, ArData(n, 4))

diese
oDicGes(ArData(n, 1)) = "=RC[-2]*RC[-1]"
Gruß Tino


  

Betrifft: AW: in deiner Liste ist ganz unten noch eine Tabelle von: Ron Dmc
Geschrieben am: 29.10.2014 10:16:35

Hallo Tino,

leider immer noch falsch.
In Spalte C solle einfach der einzel Preis übergeben werden. (Jetzt rechnet er da bereits die Summe)
Dieser Einzelpreis soll dann * die Stückzahl Zelle B in Zelle D ausgegeben werden
So soll es aussehen
ArtNr. Stückzahl Preis Gesamt
403369 4 14,99 59,96


Danke!!!!!


  

Betrifft: AW: in deiner Liste ist ganz unten noch eine Tabelle von: Tino
Geschrieben am: 29.10.2014 15:05:41

Hallo,
mach aus der Zeile

»ODicBrutto(ArData(n, 1)) = ODicBrutto(ArData(n, 1)) + IIf(IsError(ArData(n, 3)), 0, ArData(n, 3))
diese
»ODicBrutto(ArData(n, 1)) = IIf(IsError(ArData(n, 3)), 0, ArData(n, 3))

PS:hast du mal versucht den Code zu verstehen?

Gruß Tino


  

Betrifft: AW: gleiche Zellen addieren, sortieren, und doppelte von: fcs
Geschrieben am: 25.10.2014 13:23:12

Hallo Ron,

benutze für die Auswertung deiner Daten einen Pivottabellenbericht.
Natürlich kann man die Liste auch per Makro machen. Aber warum unbedingt Makros erstellen, wenn es auch geeignete Bordwerkzeuge gibt.

Gruß
Franz


  

Betrifft: AW: gleiche Zellen addieren, sortieren, und doppelte von: Ron Dmc
Geschrieben am: 25.10.2014 14:06:47

Vielen Dank für die schnelle Hilfe. Mit Pivot-Tabellen kenne ich mich noch nicht aus. (Werde ich aber mal versuchen)
Das Makro funktioniert schon ganz gut, folgende Dinge wären aber noch sinnvoll:
1. ArtNr. werder sortiert
2. Die Daten des Makros werden in Tabellenblatt2 gespeichert

Außerdem habe ich noch eine Frage.
Da die Eingabe der ArtNr. mit Hilfe eines EAN-Scanners passiert, wäre es schön, wenn das alles Live passieren würde.
Bedeutet: man scannt einen Code (13stellige Zahl) und sollte es der gleiche sein, wird die Sückzahl automatisch um 1 erhöht. Ist soetwas mit Excel eigentlich umzusetzen?

Vielen Dank Vorab.


 

Beiträge aus den Excel-Beispielen zum Thema "gleiche Zellen addieren, sortieren, und doppelte"