Sommen.als functie in vba

Status
Niet open voor verdere reacties.
K

koster1984

Gebruiker
Lid geworden
4 jul 2012
Berichten
337
Hallo,

Ik heb een overzichtje met inkoopfacturen (zie bijlage), hierin wil ik, in blad '#', achter de afdelingen een aantallen.als functie inbouwen d.m.v. een 'Worksheet_Activate' sub in vba (omdat het over een variabel aantal tabbladen gaat).

Onderstaande code heb ik gemaakt:
Code: 
Private Sub Worksheet_Activate()
Dim ws As Long, q As Range, r As Range, i As Range
For ws = 4 To Sheets.Count
Set q = Sheets(ws).Columns(12)
Set i = Sheets(ws).Columns(2)
Set r = ActiveSheet.Range("B4:B" & Range("A1").Value)
r.Offset(0, 2) = WorksheetFunction.CountIfs(i, [D1], q, [B4])
Exit For
Next ws
End Sub
De aantallen.als functie werkt in principe, maar ik kan hem maar voor één afdeling tegelijk berekenen (heb om deze werkend te krijgen, in de 'CountIfs'-functie, de bereiken ingevuld) .. Weet iemand mij te helpen aan een betere code? (voorbeeld bestandje biedt hopelijk iets meer duidelijkheid).
 

Bijlagen

Ik heb het even met 'for each it' geprobeerd, maar het werkt nog niet helemaal (alhoewel hij geen foutmelding geeft):

Code: 
Private Sub Worksheet_Activate()
Dim ws As Long, q As Range, r As Range, i As Range
For ws = 4 To Sheets.Count
Set q = Sheets(ws).Columns(12)
Set i = Sheets(ws).Columns(2)
Set r = ActiveSheet.Range("B4:B" & Range("A1").Value)
For Each it In r
it.Offset(0, 2) = WorksheetFunction.CountIfs(i, [D1], q, it.Offset(0, -1))
Next
Exit For
Next ws
End Sub

..niemand een suggestie voor me?
 
OK... ik heb hem zo werkend gekregen voor alleen de eerste kolom:
Code: 
Private Sub Worksheet_Activate()
Dim ws As Long, q As Range, r As Range, i As Range, x As Double
For ws = 4 To Sheets.Count
Set q = Sheets(ws).Columns(12)
Set i = Sheets(ws).Columns(2)
Set r = ActiveSheet.Range("B4:B" & Range("A1").Value)
For Each it In r
x = WorksheetFunction.CountIfs(i, [D1], q, it)
it.Offset(0, 2) = x
Next
Exit For
Next ws
End Sub

Weet één van de experts misschien hoe ik hem het beste voor de overige 11 kolommen kan instellen?
 
Hij doet met onderstaande code precies wat ik wil, maar gezien het een vrij omslachtige is hoop ik nog altijd op een suggestie van iemand om deze te verbeteren:
Code: 
Private Sub Worksheet_Activate()
Dim ws As Long, q As Range, i As Range, p As Range, r As Range
For ws = 4 To Sheets.Count
    Set q = Sheets(ws).Columns(12)
    Set i = Sheets(ws).Columns(2)
    Set p = Sheets(ws).Columns(3)
    Set r = ActiveSheet.Range("B4:B" & Range("A1").Value + 1)
Application.ScreenUpdating = False
For Each it In r
If it.Value <> "" Then
    With it
        .Offset(0, 2) = WorksheetFunction.CountIfs(i, [D1], q, it)
        .Offset(0, 2).Interior.ColorIndex = 19
        .Offset(0, 3) = WorksheetFunction.CountIfs(i, [E1], q, it)
        .Offset(0, 3).Interior.ColorIndex = 19
        .Offset(0, 4) = WorksheetFunction.CountIfs(i, [F1], q, it)
        .Offset(0, 4).Interior.ColorIndex = 19
        .Offset(0, 5) = WorksheetFunction.CountIfs(i, [G1], q, it)
        .Offset(0, 5).Interior.ColorIndex = 19
        .Offset(0, 6) = WorksheetFunction.CountIfs(i, [H1], q, it)
        .Offset(0, 6).Interior.ColorIndex = 19
        .Offset(0, 7) = WorksheetFunction.CountIfs(i, [I1], q, it)
        .Offset(0, 7).Interior.ColorIndex = 19
        .Offset(0, 8) = WorksheetFunction.CountIfs(i, [J1], q, it)
        .Offset(0, 8).Interior.ColorIndex = 19
        .Offset(0, 9) = WorksheetFunction.CountIfs(i, [K1], q, it)
        .Offset(0, 9).Interior.ColorIndex = 19
        .Offset(, 10) = WorksheetFunction.CountIfs(i, [L1], q, it)
        .Offset(, 10).Interior.ColorIndex = 19
        .Offset(, 11) = WorksheetFunction.CountIfs(i, [M1], q, it)
        .Offset(, 11).Interior.ColorIndex = 19
        .Offset(, 12) = WorksheetFunction.CountIfs(i, [N1], q, it)
        .Offset(, 12).Interior.ColorIndex = 19
        .Offset(, 13) = WorksheetFunction.CountIfs(i, [O1], q, it)
        .Offset(, 13).Interior.ColorIndex = 19
        .Offset(, 15) = WorksheetFunction.Sum(Range(.Offset(0, 2).Address & ":" & .Offset(, 13).Address))
        .Offset(, 15).Interior.ColorIndex = 15
        .Offset(, 17) = WorksheetFunction.CountIfs(p, "v", q, it)
        .Offset(, 17).Interior.ColorIndex = 15
        .Offset(, 19) = .Offset(, 15) - .Offset(, 17)
        .Offset(, 19).Interior.ColorIndex = 15
    End With
Else
    With it
        .Offset(0, 2) = WorksheetFunction.Sum(Range("D4:D" & Range("A1").Value))
        .Offset(0, 2).Interior.ColorIndex = 40
        .Offset(0, 3) = WorksheetFunction.Sum(Range("E4:E" & Range("A1").Value))
        .Offset(0, 3).Interior.ColorIndex = 40
        .Offset(0, 4) = WorksheetFunction.Sum(Range("F4:F" & Range("A1").Value))
        .Offset(0, 4).Interior.ColorIndex = 40
        .Offset(0, 5) = WorksheetFunction.Sum(Range("G4:G" & Range("A1").Value))
        .Offset(0, 5).Interior.ColorIndex = 40
        .Offset(0, 6) = WorksheetFunction.Sum(Range("H4:H" & Range("A1").Value))
        .Offset(0, 6).Interior.ColorIndex = 40
        .Offset(0, 7) = WorksheetFunction.Sum(Range("I4:I" & Range("A1").Value))
        .Offset(0, 7).Interior.ColorIndex = 40
        .Offset(0, 8) = WorksheetFunction.Sum(Range("J4:J" & Range("A1").Value))
        .Offset(0, 8).Interior.ColorIndex = 40
        .Offset(0, 9) = WorksheetFunction.Sum(Range("K4:K" & Range("A1").Value))
        .Offset(0, 9).Interior.ColorIndex = 40
        .Offset(, 10) = WorksheetFunction.Sum(Range("L4:L" & Range("A1").Value))
        .Offset(, 10).Interior.ColorIndex = 40
        .Offset(, 11) = WorksheetFunction.Sum(Range("M4:M" & Range("A1").Value))
        .Offset(, 11).Interior.ColorIndex = 40
        .Offset(, 12) = WorksheetFunction.Sum(Range("N4:N" & Range("A1").Value))
        .Offset(, 12).Interior.ColorIndex = 40
        .Offset(, 13) = WorksheetFunction.Sum(Range("O4:O" & Range("A1").Value))
        .Offset(, 13).Interior.ColorIndex = 40
        .Offset(, 15) = WorksheetFunction.Sum(Range("Q4:Q" & Range("A1").Value))
        .Offset(, 15).Interior.ColorIndex = 16
        .Offset(, 17) = WorksheetFunction.Sum(Range("S4:S" & Range("A1").Value))
        .Offset(, 17).Interior.ColorIndex = 16
        .Offset(, 19) = WorksheetFunction.Sum(Range("U4:U" & Range("A1").Value))
        .Offset(, 19).Interior.ColorIndex = 16
    End With
End If
Next
Exit For
Next ws
Application.ScreenUpdating = True
End Sub

Ik heb er trouwens ook wat kleurtjes bij laten verwerken en een som aan het einde van iedere kolom..
 
De eerste helft.
J as long declareren.
Code: 
If it.Value <> "" Then
    With it
     For J = 2 To 13
        .Offset(0, J) = WorksheetFunction.CountIfs(i, Cells(1, 2 + J), q, it)
        .Offset(0, J).Interior.ColorIndex = 19
      Next J
        .Offset(, 15) = WorksheetFunction.Sum(Range(.Offset(0, 2).Address & ":" & .Offset(, 13).Address))
        .Offset(, 15).Interior.ColorIndex = 15
        .Offset(, 17) = WorksheetFunction.CountIfs(p, "v", q, it)
        .Offset(, 17).Interior.ColorIndex = 15
        .Offset(, 19) = .Offset(, 15) - .Offset(, 17)
        .Offset(, 19).Interior.ColorIndex = 15
    End With
Else
De andere helft mag je zelf proberen.
 
Dankje Harry,

Ik ben er nog steeds (sinds vanmiddag) mee bezig.. dus ik begin het steeds beter te begrijpen. Dit is wat ik zocht!

Weer wat geleerd.

Dankje
 
Beste Harry,

..

laat maar ik heb het al gevonden.

Gr,
Daniel
 
Laatst bewerkt:
Beste Harry,

nog even voor de feedback;
De uiteindelijke code is de onderstaande geworden. Hij werkt perfect .. nogmaals bedankt!

Gr,
Daniel

Code: 
Private Sub Worksheet_Activate()
Dim ws As Long, q As Range, i As Range, p As Range, r As Range, J As Long
For ws = 4 To Sheets.Count
    Set q = Sheets(ws).Columns(12)
    Set i = Sheets(ws).Columns(2)
    Set p = Sheets(ws).Columns(3)
    Set r = ActiveSheet.Range("B4:B" & Range("A1").Value + 1)
CommandButton1.Caption = IIf([AD2] <> "", "Boekjaar wijzigen", "Boekjaar instellen")
Application.ScreenUpdating = False
For Each it In r
If it.Value <> "" Then
    With it
     For J = 2 To 13
        .Offset(0, J) = WorksheetFunction.CountIfs(i, Cells(1, 2 + J), q, it)
        .Offset(0, J).Interior.ColorIndex = 19
      Next J
        .Offset(, 15) = WorksheetFunction.Sum(Range(.Offset(0, 2).Address & ":" & .Offset(, 13).Address))
        .Offset(, 15).Interior.ColorIndex = 15
        .Offset(, 17) = WorksheetFunction.CountIfs(p, "v", q, it)
        .Offset(, 17).Interior.ColorIndex = 15
        .Offset(, 19) = .Offset(, 15) - .Offset(, 17)
        .Offset(, 19).Interior.ColorIndex = 15
    End With
Else
    With it
     For J = 2 To 13
        .Offset(0, J) = WorksheetFunction.Sum(Range(Cells(4, 2 + J).Address & ":" & Cells(Range("A1").Value, 2 + J).Address))
        .Offset(0, J).Interior.ColorIndex = 40
      Next J
        .Offset(, 15) = WorksheetFunction.Sum(Range("Q4:Q" & Range("A1").Value))
        .Offset(, 15).Interior.ColorIndex = 16
        .Offset(, 17) = WorksheetFunction.Sum(Range("S4:S" & Range("A1").Value))
        .Offset(, 17).Interior.ColorIndex = 16
        .Offset(, 19) = WorksheetFunction.Sum(Range("U4:U" & Range("A1").Value))
        .Offset(, 19).Interior.ColorIndex = 16
    End With
End If
Next
Exit For
Next ws
With ActiveSheet.Range("D" & Range("A1").Value + 2 & ":U83")
                                                            .ClearContents
                                                            .Interior.ColorIndex = 2
End With
Application.ScreenUpdating = True
End Sub
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan