Fehler von VBA-Lösung finden

Hallo,

ich habe eine Datei mit 2 Tabellen:
- Bestellungen
- Warengruppen

In der Tabelle Bestellungen soll täglich geprüft werden, aus welchen Warengruppen die Bestellungen eingehen. Dafür habe ich beginnend in der Zelle I13 folgende Formel, die funktioniert:

=WENN(Warengruppen!$A1="";"";SUMME(ZÄHLENWENN(I$2:I$11;Warengruppen!$A1:$J1)))
Diese Formel wird nach rechts und unten kopiert, weswegen die Spalten bzw. die Zeilen fixiert sind.

Da das Gesamtprojekt sehr viele Daten umfasst, möchte ich diese Formel per VBA lösen. Dazu habe ich mir zunächst per Makro die VBA-Lösung aufzeichnen lassen:

Sub Aufzeichnung()

With Worksheets("Bestellungen")
Range("I13").Select
ActiveCell.Formula2R1C1 = _
"=IF(WARENGRUPPEN!R[-12]C1="""","""",SUM(COUNTIF(R2C:R11C,WARENGRUPPEN!R[-12]C1:R[-12]C10)))"
Range("I14").Select

End With

End Sub

Funktioniert soweit.

Jetzt möchte diese Formel per VBA auf die Zellen I13 : S15 erweitern. Ich habe nach diversen Versuchen zwei Lösungen, die als Sub akzeptiert werden, beim Ausführen kommen aber Fehlermeldungen:

Fehler beim Kompilieren:
Falsche Anzahl an Argumenten oder ungültige Zuweisung zu einer Eigenschaft

Das sind meine Lösungsansätze:
Sub Formel_7()
Dim i As Integer, j As Integer
Dim result As Variant
With Worksheets("Bestellungen")
For i = 13 To 15
For j = 9 To 19
If Worksheets("WARENGRUPPEN").Cells(i - 12, 1).Value > "" Then
result = WorksheetFunction.CountIf(Range(Cells(i - 12, 0), (Cells(i - 2, 0)), Worksheets("WARENGRUPPEN").Cells(i - 12, 1).Value))
Else
result = ""
End If
Cells(i, j).Value = result
Next j
Next i
End With
End Sub

Sub Formel_8()
Dim i As Integer, j As Integer
Dim result As Variant
With Worksheets("Bestellungen")
For i = 13 To 15
For j = 9 To 19
If Worksheets("WARENGRUPPEN").Cells(i - 12, 1).Value > "" Then
result = WorksheetFunction.CountIf(Cells(i - 12, 0), (Cells(i - 2, 0)), Worksheets("WARENGRUPPEN").Cells(i - 12, 1).Value)
Else
result = ""
End If
Cells(i, j).Value = result
Next j
Next i
End With
End Sub

Hier noch meine Musterdatei:
https://www.herber.de/bbs/user/167124.xlsm

Wo liegen meine Fehler?

Vielen Dank für eine Hilfe.

mfg

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub test() Dim WGrng As Range Dim WGarr Dim BESTrng As Range Dim BESTarr Dim ERGrng As Range Dim ERGarr Dim DATrng As Range Dim DATarr Dim GRPrng As Range Dim GRParr Dim z As Long, s As Long Dim WGdic As Object Dim dic As Object Dim ID As String Set WGrng = Sheets("WarenGruppen").Range("A1:L5") Set BESTrng = Sheets("Bestellungen").Range("I2:S11") Set ERGrng = Sheets("Bestellungen").Range("I13:S17") Set DATrng = Sheets("Bestellungen").Range("I1:S1") Set GRPrng = Sheets("Bestellungen").Range("B13:B17") WGarr = WGrng.Value BESTarr = BESTrng.Value ReDim ERGarr(1 To ERGrng.Rows.Count, 1 To ERGrng.Columns.Count) DATarr = DATrng.Value GRParr = GRPrng.Value '--- Gruppenzuordnung einlesen Set WGdic = CreateObject("scripting.dictionary") For s = 1 To UBound(WGarr, 2) - 2 For z = 1 To UBound(WGarr, 1) WGdic(WGarr(z, s)) = WGarr(z, UBound(WGarr, 2)) Next Next '--- Mengen pro Tag und Gruppe zählen Set dic = CreateObject("scripting.dictionary") For s = 1 To UBound(BESTarr, 2) For z = 1 To UBound(BESTarr, 1) ID = DATarr(1, s) & "|" & WGdic(BESTarr(z, s)) dic(ID) = dic(ID) + 1 Next Next '--- Ergebnis zurückschreiben For s = 1 To UBound(ERGarr, 2) For z = 1 To UBound(ERGarr, 1) ID = DATarr(1, s) & "|" & GRParr(z, 1) ERGarr(z, s) = dic(ID) Next Next ERGrng = ERGarr End Sub

'--- Ergebnis zurückschreiben For s = 1 To UBound(ERGarr, 2) For z = 1 To UBound(ERGarr, 1) ID = DATarr(1, s) & "|" & GRParr(z, 1) if dic.Exists(ID) then ERGarr(z, s) = dic(ID) else ERGarr(z, s) = 0 end if Next Next

Sub Formel_8() Dim i&, j&, lrow&, lmaxCol&, lminCol& Dim shBestell As Worksheet Dim rngWaGrp As Range, rngWGRef As Range Dim wf Set wf = WorksheetFunction Set shBestell = ThisWorkbook.Worksheets("Bestellungen") lminCol = Columns("I").Column lmaxCol = shBestell.Cells(1, Columns.Count).End(xlToLeft).Column lrow = shBestell.Cells(Rows.Count, 2).End(xlUp).Row With ThisWorkbook.Worksheets("WARENGRUPPEN") Set rngWaGrp = .Range("$A$1:$I$5") Set rngWGRef = .Range("$L$1:$L$5") End With Application.Calculation = xlCalculationManual Application.ScreenUpdating = False For i = 2 To lrow If Left(Cells(i, 2), Len("Gruppe ")) = "Gruppe " Then For j = lminCol To lmaxCol On Error Resume Next Cells(i, j).Value = wf.Sum( _ wf.CountIf( _ shBestell.Cells(2, j).Resize(10), _ wf.Index( _ rngWaGrp, _ wf.Match( _ Cells(i, 2), _ rngWGRef, _ 0 _ ) _ , 0) _ ) _ ) If Err > 0 Then Cells(i, j).Value = "Fehler" & Err.Number: Err.Clear Next j End If Next i Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub

versuchs mal damit. die 36 Minuten scheinen etwas viel. das erste Makro rechnet nicht richtig weil die Warengruppen nur bis i und nicht bis Spalte j eingebunden war.
Aber das hast du sicher selbst beim anpassen der Bereiche gemerkt.

Sub Formel_Arr()



Dim i&, j&, lrow&, lmaxCol&, lminCol&, cnt&, e&, r&, s&, erg&, frstrow&

Dim shBestell As Worksheet

Dim varrWaGrp, varrWGRef, varrData, varrTmp, varrB, varrErg

Dim wf



Set wf = WorksheetFunction

Set shBestell = ThisWorkbook.Worksheets("Bestellungen")



lminCol = Columns("I").Column

lmaxCol = shBestell.Cells(1, Columns.Count).End(xlToLeft).Column

lrow = shBestell.Cells(Rows.Count, 2).End(xlUp).Row



With ThisWorkbook.Worksheets("WARENGRUPPEN")

    varrWaGrp = .Range("$A$1:$J$5").Value

    varrWGRef = .Range("$L$1:$L$5").Value

End With



Application.Calculation = xlCalculationManual

Application.ScreenUpdating = False



'bereich Bestellungen

varrData = shBestell.Cells(2, lminCol).Resize(10, lmaxCol).Value



For i = 2 To lrow

  'zeile mit "Gruppe x"

  

  If Left(Cells(i, 2), Len("Gruppe ")) = "Gruppe " Then

     If frstrow = 0 Then frstrow = i

     cnt = cnt + 1

     'speicher für ergebniszeile

     If cnt = 1 Then

        ReDim varrErg(1 To lmaxCol - lminCol + 1, 1 To 1)

     Else

        ReDim Preserve varrErg(1 To lmaxCol - lminCol + 1, 1 To cnt)

     End If

    'WAgruppe finden und Wagr zeile im tmp

     For e = 1 To UBound(varrWGRef)

        If varrWGRef(e, 1) = Cells(i, 2) Then varrTmp = wf.Index(varrWaGrp, e, 0): Exit For

     Next

         

     'die ergebniszeile von links nach rechts

     For r = LBound(varrErg) To UBound(varrErg)

        

        ' aktuelle spalte der bestellungen

        varrB = wf.Index(varrData, 0, r)

        

        erg = 0

        'schleife über die auszuwertenden teilbereiche

        For j = LBound(varrB) To UBound(varrB)

            For s = LBound(varrTmp) To UBound(varrTmp)

                'addition der Funde

                If varrB(j, 1) = varrTmp(s) Then erg = erg + 1: Exit For

            Next s

        Next j

        varrErg(r, cnt) = erg

     Next r

    

  Else

    

  End If

Next i



'Ergebnisarray drehen

varrErg = Application.Transpose(varrErg)



'werte in Tabelle schreiben

 Cells(frstrow, lminCol).Resize(UBound(varrErg), UBound(varrErg, 2)) = varrErg



Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True



End Sub

Beliebteste Forumthreads (12 Monate)

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Fehler von VBA-Lösung finden

18 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread