100 werbladen automatiseren

[Sytse1]

Voor wedstrijdschema's bezit ik 100 werkbladen die geschikt voor het importeren in Access gemaakt moeten worden.
Ik sluit het werkblad bij.
Elk werkblad/wedstrijdschema is voor het aantal aanwezige spelers. Er zijn altijd 5 rondes.
En er wordt 2 tegen 2 of 3 tegen 2 gespeeld afhankelijk van het aantal spelers.
In VBA moet de ronde met 1 opgehoogd worden als in de cel in kolom B geen spelersnummer staat.
Nadat de 5 rondes zijn ingevuld moeten de lege regels(regels waar geen spelersnummer in staan) verwijderd worden.
Ik heb de volgende niet werkende VBA poging gedaan.

Sub Test()
'als in cel b2 het cijfer > dan 0 is ronde 1
'tot de cel leeg is dan RKA met 1 ophogen tot ronde 5
'KB = kolom B dan een cijfer voor de celaanduiding KBC
'KB en KBR = KBT celnummer
'KA = kolom A, KAR Cel nr, KAT = KA + KAR celnr in kolom a
Dim RKA, KB, KBC, KBT, KA, KAR, KAT
Dim Check, Counter
RKA = 1         'RKA = ronde in kolom A
KA = "a"        'kolom a
KAR = 2         'rij 2
KAT = KA & KAR  'cel in kolom a
KB = "b"        'kolom b
KBR = 2         'rij 2
KBT = KB & KBR  'cel in kolom b

Check = True
Do
Do While RKA < 10
If KBT > 1 Or KBT <> " " Then
Range(KAT).Select
    ActiveCell.FormulaR1C1 = RKA
ElseIf KBT < 1 Or KBT = " " Then
KAR = KAR + 1
KAT = KA & KAR  'cel in kolom a
End If
KBR = KBR + 1
KBT = KB & KBR  'cel in kolom b
If RKA > 5 Then
Check = False
Exit Do
End If
Loop
Loop Until Check = False
End Sub

Wellicht veel te uitgebreid.
Wie weet een eenvoudige oplossing.b.v.d.
Sytse
Bekijk bijlage 30Spelers.xls

 

[Cheetahke]

Hoi,

Ik zal je bestandje eens bekijken.

Groetjes,

 

[VenA]

Ik denk dat zoiets voldoende is.

Sub VenA()
With Sheets(1)
    For Each cl In .UsedRange
        cl.Value = Trim(cl.Value)
    Next cl
    For Each cl In .Range("A3:A" & .Cells(Rows.Count, 2).End(xlUp).Row)
        If Not cl.Offset(, 1) = "" Then cl.Value = cl.Offset(-1).Value Else cl.Value = cl.Offset(-2).Value + 1
    Next cl
    .Columns(2).SpecialCells(4).EntireRow.Delete
End With
End Sub

 

[Cheetahke]

@VenA

Jouw code werkt inderdaad.

@Sytse1

Ik heb de code van VenA getest in jouw voorbeeldje, en het werkt inderdaad indien alle werkbladen er zo uitzien als in jouw voorbeeldje.
Indien er geen lege cellen zijn tussen de verschillende rondes en na het laatst ingevulde gegeven in kolom B, dan vormen zich 2 problemen...
1e probleem is dat in kolom A alle rondes terug op 1 komen te staan
2e probleem is dat er geen rijen meer kunnen verwijderd worden, omdat er geen zijn, en dan krijg je een foutmelding op deze code:

.Columns(2).SpecialCells(4).EntireRow.Delete

Groetjes

 

[Sytse1]

VenA geweldig bedankt.
Je code werkt uitstekend.
Jouw code is een stuk compacter dan ik kan bedenken.
Het door Cheetahke gesignaleerde probleem heb ik niet ondervonden.
Beide bedankt voor het meedenken en de code.
Groet,
Sytse