2 VBA codes om op te tellen maar beiden een fout

[adile]

goedenavond,

ik heb 2 vba codes voor de zelfde actie,
maar beiden zit er een probleem in.

de code telt het aantal personen op uit 4 werkbladen bij elkaar op en zet bij de aantallen boven de 1 het aantal achter de betreffende naam, met de meest voorkomende bovenaan.

de eerste code telt alles goed op alleen wanneer hij maar 1 naam tegenkomt noteert hij deze 2 keer op het telblad.
de tweede doet ook zijn werk, maar deze telt ook de LEGE cellen bij alkaar op.

nu is mijn vraag welke code is het beste, en hoe los ik dat kleine probleempje op.

bestandje met de codes heb ik toegevoegd en door op de buttons te klikken in eindlijst en eindlijst2,
zie je direct wat ze fout doen.

Gr Adile

 

[HSV]

Maak het zo in je dictionary van eindlijst2.

for x = 5 To y
     If .Cells(x, 7) > 0 Then dic(.Cells(x, 7).Value) = dic(.Cells(x, 7).Value) + 1
  Next x

Als je spaties achter de namen hebt staan, en bij sommige niet, krijg die namen apart en apart opgeteld.

 

[snb]

Zo kan het ook:

Private Sub CommandButton1_Click()
    With CreateObject("Scripting.Dictionary")
        For Each ws In Sheets([transpose("week" & row(1:53))])
            sn = ws.Cells(5, 7).Resize(ws.Cells(Rows.Count, 7).End(xlUp).Row - 4)
            For j = 1 To UBound(sn)
                If sn(j, 1) <> "" Then .Item(Trim(sn(j, 1))) = .Item(Trim(sn(j, 1))) + 1
            Next
        Next
        sp = .keys
        sq = .items
    End With
        
     With Sheets("eindlijst2").Cells(3, 2)
        .CurrentRegion.Offset(1).ClearContents
        .Offset(1).Resize(UBound(sp) + 1, 2) = Application.Transpose(Array(sp, sq))
        .CurrentRegion.Offset(1).Sort .Offset(1, 1), 2
    End With
End Sub

 

[HSV]

Of:

Sheets("eindlijst2").Cells(3, 2).CurrentRegion.Offset(1).ClearContents
Sheets("eindlijst2").Cells(3, 2).Offset(1).Resize(.Count) = Application.Transpose(.keys)
Sheets("eindlijst2").Cells(3, 2).Offset(1, 1).Resize(.Count) = Application.Transpose(.items)

wordt.

Sheets("eindlijst2").Cells(3, 2).CurrentRegion.Offset(1).ClearContents
Sheets("eindlijst2").Cells(3, 2).Offset(1).Resize(.Count, 2) = Application.Transpose(Array(.keys, .items))

 

[adile]

Harry,

Wordt dit dan zo de code?

want als ik de oude vervang voor deze, dan krijg ik 2x een kees met een 2 erachter. het klopt dat kees 2x voor komt maar dat hoef ik maar 1x als uitkomst te hebben.

ik wil graag weten wat ik fout doe.

Adile

@Snb

Jouw code werkt indd wel. bedankt.

is er neen manier om ipv blad 1 blad 2 dit anders te benoemen, moet het toepassen op 53 weken en de sheets heten week 1 t/m week 53?

beide erg bedankt voor jullie hulp.

ik zal hem op opgelost zetten.


adile

Private Sub CommandButton1_Click()

    Dim ws      As Worksheet
    
    Dim var     As Variant
    Dim dic     As Object
    
    Dim x       As Long
    Dim y       As Long
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    For Each ws In Sheets(Array("Blad5", "Blad6", "Blad7", "Blad8"))
        With ws
            y = .Cells(.Rows.Count, 7).End(xlUp).Row
            If y > 4 Then

        For x = 5 To y
        If .Cells(x, 7) > 0 Then dic(.Cells(x, 7).Value) = dic(.Cells(x, 7).Value) + 1
        Next x
                    
                    

            End If
        End With
    Next ws
    
    With Sheets("Eindlijst2")
        y = .Cells(.Rows.Count, 2).End(xlUp).Row
        If y > 3 Then .Cells(4, 2).Resize(2, y).ClearContents
        
        x = 4
        For Each var In dic
            If dic(var) > 1 Then
                .Cells(x, 2).Value = var
                .Cells(x, 3).Value = dic(var)
                x = x + 1
            End If
        Next var
        
        y = .Cells(.Rows.Count, 2).End(xlUp).Row
        If y > 3 Then
            .Cells(3, 2).Resize(y - 2, 2).Sort key1:=.Cells(3, 3), order1:=xlDescending, Header:=xlYes
        End If
        
    End With
    
    Set dic = Nothing
    
End Sub

 

[snb]

Zie mijn laatste aanpassingen in de geplaatste code (ook met dank aan HSV !!)


Meer over dictionaries: http://www.snb-vba.eu/VBA_Dictionary.html

 

[adile]

Harry en snb,

Ik heb hem getest en hij werkt goed en stabiel.
al moest ik even puzzelen want heb het idee dat het gespreksverloop hierboven
in de goede volgorde staat

Ik wil jullie beiden hartelijk danken en ik zet je site ff bij favorieten zetten zodat ik wat meer over vba kan leren.
Fijne avond

Gr Adile

 

[adile]

SNB,

erzit toch nog 1 foutje in deze code:

Private Sub CommandButton1_Click()
    With CreateObject("Scripting.Dictionary")
        For Each ws In Sheets([transpose("blad" & row(5:8))])
            sn = ws.Cells(5, 7).Resize(ws.Cells(Rows.Count, 7).End(xlUp).Row - 4)
            For j = 1 To UBound(sn)
                If sn(j, 1) <> "" Then .Item(Trim(sn(j, 1))) = .Item(Trim(sn(j, 1))) + 1
            Next
        Next
        sp = .keys
        sq = .items
    End With
        
     With Sheets("eindlijst2").Cells(3, 2)
        .CurrentRegion.Offset(1).ClearContents
        .Offset(1).Resize(UBound(sp) + 1, 2) = Application.Transpose(Array(sp, sq))
        .CurrentRegion.Offset(1).Sort .Offset(1, 1), 2
    End With
End Sub

als erniets te tellen valt dus de cellen zijn leeg,
dan krijg ik een error.

Adile

 

[snb]

Loop door de code met F8, dan zie je vanzelf waar de fout optreedt.
Dan kun je het waarschijnlijk ook zelf oplossen.

 

[adile]

De error geeft hij aan voor dit stukje:

sn = ws.Cells(5, 7).Resize(ws.Cells(Rows.Count, 7).End(xlUp).Row - 4)

maar met F8
kan ik tot de eerste Next dan loopt hij weer terug.
daar zou ook dan ook iets fout kunnen zitten.

maar ik weer niet wat er fout zou kunnen zijn.

Het is dus zo als er op 1 blad de kolom G leeg is dan krijg ik die melding al.

Adile

 

[HSV]

Test het zo maar eens weer.

Private Sub CommandButton1_Click()
    With CreateObject("Scripting.Dictionary")
        For Each ws In Sheets([transpose("blad" & row(5:8))])
        sn = ws.Range(ws.Cells(5, 7), ws.Cells(Application.Max(5, ws.Cells(Rows.Count, 7).End(xlUp).Row), 7))
           If Application.Max(5, ws.Cells(Rows.Count, 7).End(xlUp).Row) > 5 Then
            For j = 1 To UBound(sn)
                If sn(j, 1) <> "" Then .Item(Trim(sn(j, 1))) = .Item(Trim(sn(j, 1))) + 1
            Next
           End If
        Next
        sp = .keys
        sq = .items
    End With
        
     With Sheets("eindlijst2").Cells(3, 2)
        .CurrentRegion.Offset(1).ClearContents
        .Offset(1).Resize(UBound(sp) + 1, 2) = Application.Transpose(Array(sp, sq))
        .CurrentRegion.Offset(1).Sort .Offset(1, 1), 2
    End With
End Sub

 

[adile]

HSV,

Sorry voor de late reactie, maar heb jouw code op alle manieren getest en hij werkt :thumb:

hartelijk dank voor je hulp.

Adile