Thema: Makro erweitern für weitere Spalten | Herbers Excel-Forum

Hallo zusammen,
ich hatte vor einiger Zeit ein ähnliches Problem und ransi hat mir dabei geholfen.
Wenn einer von euch ransi kennt könnt ihr ihm bitte Bescheid geben.
Denn ich habe folgendes Problem.
ich habe folgende Auswertung: https://www.herber.de/bbs/user/66225.xls
Und das Makro sieht so aus. und funktioniert !!!!! Soll heißen, die Summen werden korrekt angezeigt.
Nur wenn ich vor der Spalte E noch eine Spalte einfüge und das Makro so anpassen wie hier: https://www.herber.de/bbs/user/66527.xls
Dann wird die Summe nicht mehr richtig gebildet. Habe ich einen Denkfehler oder bin ich zu doof.
Schon einmal vorab vielen Dank und ein schönes Wochende.
Option Explicit

Public Sub test()
Dim arr As Variant
Dim L As Long
arr = Range("C15:H10000")
For L = 1 To UBound(arr)
If arr(L, 3) = "" Then
arr(L, 3) = WorksheetFunction.SumIf(Range("C15:C10000"), arr(L, 1) & ".*", Range("E15: _
E10000"))
arr(L, 4) = WorksheetFunction.SumIf(Range("C15:C10000"), arr(L, 1) & ".*", Range("F15: _
F10000"))
arr(L, 5) = WorksheetFunction.SumIf(Range("C15:C10000"), arr(L, 1) & ".*", Range("G15: _
G10000"))
arr(L, 6) = WorksheetFunction.SumIf(Range("C15:C10000"), arr(L, 1) & ".*", Range("H15: _
H10000"))
If arr(L, 3) = 0 Then arr(L, 3) = ""
If arr(L, 4) = 0 Then arr(L, 4) = ""
If arr(L, 5) = 0 Then arr(L, 5) = ""
If arr(L, 6) = 0 Then arr(L, 6) = ""
End If
Next
Range("C15:H10000") = arr
End Sub

Grüße
Henning

Hallo Henning,
ich habe das Makro eben mal in der erweiterten Tabelle laufen lassen : Die Ergebnisse sind korrekt !
Das kann man per Tabellenblattfunktion überprüfen (z.B. in B15 eingeben und dann runterkopieren) :
=SUMMEWENN($C$15:$C$66;C15&"*";$F$15:$F$66)
Hier ein Screenshot des Ergebnisses (Prüfungsfunktionen in Grünen Spalten, Spalten L:P enthalten die ursprünglichen Originalwerte) :

Das einzige was an Deiner hochgeladenen Mappe merkwürdig war :
Der Makrocode war in einem falschen Format, genauer die TABS vor jeder Codezeile !
Diese musste ich erst durch "echte" Tabs ersetzen, damit der Code gestartet werden konnte !
Gruß, NoNet

Hallo NoNet,
sorry, da habe ich mich verkehrt ausgedrückt.
Das Makro rechnet dann falsch wenn ich noch eine Spalte, z.B. zum Komentieren
Das Beispiel und den Code findest du hier
https://www.herber.de/bbs/user/66527.xls
Danke und Gruß
Henning

Hallo Henning,
NoNet hatte schon darauf hingewiesen, daß mit dem Vba-Makro etwas nicht stimmt. Wenn ich Deine Datei öffne und mir das Makro ansehe, so sind manche Zeilen rot dargestellt.
In dieser (roten) Zeile '    If arr(L, 3) = "" Then' sind die ersten 4 Zeichen keine Leerzeichen (ASCII-Code 32) sondern entsprechen dem ASCII-Code 160. Was soll das; womit schreibst Du den Vba-Code.
Das Makro kann überhaupt nicht funktionieren.
Gruß von Luschi
aus klein-Paris

Hallo Henning,
damit das Makro auch bei eingefügten Spalten noch richtig funktioniert, musst Du die Bezüge anpassen.
Ich habe das mal in Abhängigkeit der Beschriftung "Budget" gemacht, das Makro funktioniert nun bei 1,2,3,4,... eingefügten Spalten vor "Budget" :

Sub VariableSpalten()
Dim Arr As Variant, lngLS As Long, lngS As Long
Dim rngBereich As Range, rngPSP As Range
Dim L As Long
lngS = Application.Match("Budget", Rows("14:14"), 0) - 5 'Sucht "Budget" in Zeile 15
lngLS = Cells(14, Columns.Count).End(xlToLeft).Column
Set rngPSP = Range("C15").CurrentRegion.Offset(1).Resize(10000, 1)
Set rngBereich = Range("C15").CurrentRegion.Offset(1).Resize(10000, lngLS - 1)
Arr = rngBereich
For L = 1 To UBound(Arr)
If Arr(L, 3 + lngS) = "" Then
Arr(L, 3 + lngS) = WorksheetFunction.SumIf(rngPSP, Arr(L, 1) & ".*", _
Range("E15:E10000").Offset(, lngS))
Arr(L, 4 + lngS) = WorksheetFunction.SumIf(rngPSP, Arr(L, 1) & ".*", _
Range("F15:F10000").Offset(, lngS))
Arr(L, 5 + lngS) = WorksheetFunction.SumIf(rngPSP, Arr(L, 1) & ".*", _
Range("G15:G10000").Offset(, lngS))
Arr(L, 6 + lngS) = WorksheetFunction.SumIf(rngPSP, Arr(L, 1) & ".*", _
Range("H15:H10000").Offset(, lngS))
If Arr(L, 3 + lngS) = 0 Then Arr(L, 3 + lngS) = ""
If Arr(L, 4 + lngS) = 0 Then Arr(L, 4 + lngS) = ""
If Arr(L, 5 + lngS) = 0 Then Arr(L, 5 + lngS) = ""
If Arr(L, 6 + lngS) = 0 Then Arr(L, 6 + lngS) = ""
End If
Next
'Range("C15:H10000") = Arr
rngBereich = Arr
End Sub

Gruß, NoNet

Guten Morgen, NoNet,
super vielen Dank !!!!!
Jetzt kann ich weitermachen.
Gruß
Henning

Moin NoNet,
mir ist aufgefallen, dass nach dem Aufsummieren Zahlen verschwunden sind in den Spalten IST und Obligo.
Weißt du vielleicht voran das liegt.
Die Summen stimmen.
Vielen Dank im Voraus
Grzß
Henning

Hallo Henning,
zumindest in der Datei, die Du uns zur Verfügung gestellt hast, verschwinden keine Zahlen.
Hier das Ergebnis NACH dem Makro-Durchlauf : Spalten J:K enthalten zum Vergleich die Werte VOR dem Makro-Durchlauf - es besteht kein Unterschied :

	H	I	J	K
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67

Gruß, NoNet