Tellen met VBA

  • Onderwerp starter Onderwerp starter Ibok
  • Startdatum Startdatum
Status
Niet open voor verdere reacties.
I

Ibok

Gebruiker
Lid geworden
29 sep 2010
Berichten
35
Goedemiddag,

Alweer een poosje geleden voor mij op dit forum, maar ik loop nu al een paar dagen te klooien met een code.

Wat moet er gebeuren?
Aan de hand van het eerste tabblad (in dit geval het tabblad "Helpmij"), start ik de macro "tellenmaar".

De macro zorgt ervoor dat er twee extra sheets aangemaakt worden. Waar het "fout" gaat is op de aangemaakte sheet "Overzicht1".
Ik wil graag per klas weten, hoe vaak het voorkomt dat er een lege cel is. Dit lukt mij in principe wel, maar hij laat in het overzicht1 (kolomD) een optelling van alles zien, terwijl voor mij alleen het laatste cijfer (het uiteindelijke aantal) belangrijk is.

Wie ziet waar het fout gaat en heeft een oplossing hiervoor?
Code: 
Function Col_Letter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function

Function GetValue(row As Integer, col As Integer)
    GetValue = activesheet.Cells(row, col)
End Function

Sub Tellenmaar()

'F voorzien van een dummy waarde omdat deze standaard leeg is.
    Range("F1:F2").Value = "check"

'Samengevoegde cellen splitsen
    Rows("1:1").Select
    With Selection
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

'Waarden vastleggen
Dim sh1 As Worksheet, sh2 As Worksheet, lr As Long, br As Long, rng As Range, rng2 As Range, i As Integer, startblad As String
Dim vak As String, vaardigheid As String, klas As String, klasonthouden As String, klasnu As String, klasonthouden2 As String, iklas As Integer, iklas2 As Integer, iklas3 As Integer

startblad = activesheet.Name

Sheets.Add After:=Sheets(startblad)
    activesheet.Name = "Overzicht1"
Sheets.Add After:=Sheets("Overzicht1")
    activesheet.Name = "Overzicht2"

Set sh1 = Sheets(startblad)
Set sh2 = Sheets("Overzicht1")
Set sh3 = Sheets("Overzicht2")

lr = sh1.Cells(Rows.Count, 1).End(xlUp).row
br = sh1.Cells(2, Columns.Count).End(xlToLeft).Column
Set rng = sh1.Range("G2:" & Col_Letter(br) & lr)
Set rng2 = sh1.Range("G2:" & Col_Letter(br) & lr)

'Starten met de code
sh1.Activate

'zorgen dat de "ZK-klassen niet meegenomen worden"
Dim cellen As Range
Range("c1:c" & lr).Select
For Each cellen In Selection
If cellen Like "*ZK*" Or cellen Like "*zk*" Then
cellen.EntireRow.Delete
End If
Next

'voor elke kolom in het voorgestelde bereik
For Each rng In rng.Columns

'vaknaam vastleggen. Als er geen vaknaam boven de kolom staat, dan de voorafgaande vaknaam gebruiken
vak = GetValue(1, rng.Column)
    If vak = "" Then
        vak = rng.End(xlUp).End(xlToLeft).Value
    End If
    
'vaardigheid vastleggen
vaardigheid = GetValue(2, rng.Column)
    
'voor elke cel in de betreffende kolom
    For Each cell In rng.Cells
        'lege cellen tellen
        If cell = "" Then
            'Alle lege cellen tellen
            i = i + 1
            'iklas = iklas + 1
            'iklas2 = iklas2 + 1
            
            'klassen waar dit voorkomt
            'klasnu is de waarde van de nu gevonden cel
            klasnu = Range("C" & cell.row).Value
            'Als klasnu overeenkomt met de voorgaande klas, dan "niets", anders wordt klas gevuld met klasnu

    
                If klasnu = klasonthouden Then
                'iklas2 = iklas2 + 1
                'klas = klas & iklas3
                klas = klas & " ( " & iklas2 & " ) "
                
                ' teller iklas2 weer op 0 zetten als er een nieuwe klas passeert
                klasonthouden2 = klasonthouden
                Else
                    klas = klas & ", " & klasnu & " (" & iklas + 1 & ") " '" " & Range("C" & cell.row).Value
                End If

        End If
        'de net gevonden klas onthouden
        klasonthouden = klasnu
          iklas2 = iklas2 + 1
         ' teller iklas2 weer op 0 zetten als er een nieuwe klas passeert
                If klasonthouden = klasonthouden2 Then
                    Else
                    iklas2 = 2
                End If
        'iklas = iklas
        'iklas2 = iklas2
    Next cell
       
       'MsgBox i & " " & vaardigheid & " " & klas
       sh2.Range("A" & sh2.Cells(Rows.Count, 1).End(xlUp).row)(2, 1).Value = i
       sh2.Range("A" & sh2.Cells(Rows.Count, 1).End(xlUp).row)(1, 2).Value = vak
       sh2.Range("A" & sh2.Cells(Rows.Count, 1).End(xlUp).row)(1, 3).Value = vaardigheid
       sh2.Range("A" & sh2.Cells(Rows.Count, 1).End(xlUp).row)(1, 4).Value = klas
       i = 0
       klas = ""
       vak = ""
       iklas = 0
       iklas2 = 0

Next rng
'*******************************************************************************************
'*******************************************************************************************

'Starten met de code
sh1.Activate

For Each rng2 In rng2.Columns

vak = rng2.End(xlUp).Value
    If vak = "" Then
        vak = rng2.End(xlUp).End(xlToLeft).Value
    End If
    
vaardigheid = GetValue(2, rng2.Column)
    
    For Each cell In rng2.Cells
        'lege cellen tellen
       If cell = "" Then
       klas = Range("C" & cell.row).Value
       leerling = Range("B" & cell.row).Value
       
       sh3.Range("A" & sh3.Cells(Rows.Count, 1).End(xlUp).row)(2, 1).Value = i
       sh3.Range("A" & sh3.Cells(Rows.Count, 1).End(xlUp).row)(1, 2).Value = vak
       sh3.Range("A" & sh3.Cells(Rows.Count, 1).End(xlUp).row)(1, 3).Value = vaardigheid
       sh3.Range("A" & sh3.Cells(Rows.Count, 1).End(xlUp).row)(1, 4).Value = klas
       sh3.Range("A" & sh3.Cells(Rows.Count, 1).End(xlUp).row)(1, 5).Value = leerling
       'i = 0
       klas = ""
       'vak = ""
       leerling = ""
       End If
       i = i + 1
    Next cell

Next rng2

'overzicht2 voorzien van kolomnamen en filtering
sh3.Activate
ActiveCell.FormulaR1C1 = "ID"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "VAK"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "VAARDIGHEID"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "KLAS"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "LEERLING"
    Range("A1:E1").Select
    Selection.AutoFilter
    ActiveWorkbook.Worksheets("Overzicht2").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Overzicht2").AutoFilter.Sort.SortFields.Add Key:= _
        Range("E1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Overzicht2").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWorkbook.Worksheets("Overzicht2").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Overzicht2").AutoFilter.Sort.SortFields.Add Key:= _
        Range("D1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Overzicht2").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Cells.Select
    Cells.EntireColumn.AutoFit

End Sub

Alvast dank!

Bekijk bijlage helpmij.xlsm
 
Dag Elsendoorn2134,

Dat ik daar niet aan gedacht heb... Zat idd veel te moeilijk te denken. Ik heb het probleem opgelost.

Bedankt!
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan