Zeilen aufsummieren

Hallo,
ich habe folgendes Skript/Macro hier im Forum gefunden.


Option Explicit
Sub Makro1()
Dim LR
On Error GoTo Fehler
Columns("E:H").Insert Shift:=xlToRight
Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
"E1"), Unique:=True
LR = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row 'letzte Zeile der Spalte
Range("F2:H" & LR).FormulaLocal = "=SUMMEWENN($A:$A;$A2;B:B)"
Range("F:H").Copy
Range("F:H").PasteSpecial Paste:=xlPasteValues
Range("B1:D1").Copy Range("F1")
Columns("A:D").Delete Shift:=xlToLeft
Fehler:
If Err.Number  0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub

villeicht kann mir jemand dabei helfen es auf meine Bedürfnisse anzupassen.
Denn wenn ich es anwende wird es nur auf die Spalten B,C,D angewendet.
Bekomme somit mehrere Zeilen
mit A (erkannte Namen) , B(Summe1 aus B zugehörig zum Namen), C(Summe2 aus C zugehörig zum Namen) und D(Summe3 aus D zugehörig zum Namen)
Bei mir kommt täglich eine Spalte hinzu die aufsummiert wird/werden soll.
Kann mir einer dabei helfen, dass automatisch bis zur letzten gefüllten Spalte aufsummiert wird?
Vielen Dank im Voraus.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Also mit dem PQ in Excell bekomme ich es nicht hin.
Es will nicht in mein Hirn auch nicht mit "weg" Beschreibung.
Bin auch der Meinung dass die Wegbeschreibung nicht zum Ziel führt.
Zumindest nicht zu dem was in dem Beispiel excel Sheet zu sehen ist.
https://www.herber.de/bbs/user/141346.xlsx
Vielleicht kann mir ja jemand mit einem Macro helfen.
Das excell Sheet zeigt die Rohen Daten und auch wie das Ergebnis aussehen müßte.
Habe es manuell letztens gemacht. Ist halt nur eine menge Arbeit.
Wollte mir halt irgendwie diese Fleissarbeit / ABM irgendwie ersparen.
Wichtig ist nur dass das ein makro checkt wie viele Spalten vorhanden (das ändert sich es kommen immer wieder neue hinzu) sind und die Aufsummierung für alle Datumsspalten macht.

Sub Makro3() With ActiveSheet .UsedRange.Sort key1:=Cells(1, 1), order1:=xlAscending, Header:=xlYes With .Cells(1, 1).CurrentRegion .Copy .Offset(0, .Columns.Count + 1).PasteSpecial xlPasteValues With Selection With .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1) .Formula = "=sum(RC[" & 2 - .Column & "],IF(RC1=R[1]C1,R[1]C,0))" .Formula = .Value End With .RemoveDuplicates 1, xlNo End With 'Ausgangsdaten l?schen, wenn Ausf?hrung gew?nscht, hochkomma entfernen '.EntireColumn.Delete End With End With End Sub

Beliebteste Forumthreads (12 Monate)

21 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

21
Beiträge zum Forumthread

Beiträge zu diesem Forumthread