Onmogelijk formaat naar een tabel omzetten

[RoVo1211]

De gegevens hieronder zijn niet fictief, maar zijn niet te herleiden tot personen.

NTL 3137 2e Divisie A GrandCafé Hofplein Leiderdorp BV Leiden Zuid-West 73

Kampioen 3e Divisie A

NTL 3255 2e Divisie A Bowling P-H Medemblik BV Medemblik 75

7e plaats 1e Divisie A

NTL 3372 2e Divisie A Team Carriere BV Medemblik 75

6e plaats 2e Divisie A

NTL 3377 2e Divisie A Maxime's Pro Shop BV Den Helder 170

3e plaats 2e Divisie A

Verklaring van gegevens:
NTL=Nationale Trioleague
3137 = teamnummer
2e divisie A (oneven rij) = Huidige poule
Bowling P-H Medemblik = Team naam
BV Medemblik = Bowlingvereniging
75 = nummer van bowlingverening bij Nederlandse Bowling Federatie (NBF)
7e plaats (even rij) = rangschikking vorig seizoen
1e divisie A (even rij) = poule vorig seizoen.

Van NTL t/m nr bowlingver. bij NBF (75 in dit voorbeeld) staan allemaal in een cel en wil graag verdeeld zien over 6 kolommen en de gegevens over vorig seizoen (in de even rijen) daarachter in de kolommen G en H. Dus totaal 8 kolommen.

Hoe kan ik met een macro deze gegevens over kolommen verdelen.
Ik was zelf al begonnen om de gegevens over vorig seizoen met een macro te verplaatsen naar 1 rij hoger zodat ze achter de gegevens van het huidige seizoen komen te staan.
Daarvoor had ik de volgende macro geschreven, maar daar krijg de foutmelding dat de typen niet overeenkomen.
Ik zal wel wat over het hoofd gezien hebben, maar kan iemand mij helpen om het goed te krijgen.
De macro die ik had geschreven is:

Sub VorigSeizoen()

Dim row As Long, column As Long
If ActiveCell.Rows Mod 2 = 0 Then
    ActiveCell.Move
    ActiveCell.Offset(-1, 9).PasteSpecial Paste:=xlAll
End If
End Sub

Graag een oplossing.

 

[AHulpje]

Probeer het hier eens mee:

 

[snb]

Het kan gecompliceerder:

Sub m_snb()
  cells(1).currentregion.Offset(1).Copy Cells(1, 2)
  With Cells(1).CurrentRegion
    .AutoFilter 1, "<>NTL*"
    .Offset(1)..Columns(1).SpecialCells(12).EntireRow.Delete
    .AutoFilter
  End With
End Sub

Met de hand is dit ook uiterst eenvoudig.

 

[AHulpje]

@snb
Lees de wens van TS nog eens goed, met name:
"Van NTL t/m nr bowlingver. bij NBF (75 in dit voorbeeld) staan allemaal in een cel en wil graag verdeeld zien over 6 kolommen en de gegevens over vorig seizoen (in de even rijen) daarachter in de kolommen G en H. Dus totaal 8 kolommen."

 

[RoVo1211]

@AHulpje : Heel veel dank voor het oplossen van dit probleem.
Ik kon alleen de macro niet afspelen in het bestand dat jij me gestuurd had, want de macro werd niet vertrouwd. Ik heb de macro naar mijn eigen bestand gekopieerd en daar werkt het fantastisch.
Er zijn letterlijk enkele verenigingen die BV niet aan het begin hebben staan zoals bijvoorbeeld Asser BV.
Die enkelen kan ik wel met de hand aanpassen, maar je hebt me heel veel handwerk bespaard.

Misschien ben ik een beetje veeleisend, maar ik zou graag wat uitleg willen hebben bij de code om daar wat van te leren zodat ik het in de toekomst ook zelf kan schrijven/gebruiken en eventueel aan te passen aan een nieuwe situatie.

Nogmaals zeer veel dank.

 

[AHulpje]

Iets aangepast (resultaat op Blad2) en met uitleg

'r1 rijnummer op Blad1
'r2 rijnummer op Blad2
'a  array met alle elementen van de oneven rij, gesplitst op spatie, a(0) is het eerste element
'b  array met alle elementen van de even rij, idem
Sub Splitsen()
    With Sheets("Blad2")                        'werkblad waar het resultaat komt te staan
        .Cells.Delete Shift:=xlUp               'werkblad leeg maken
        For r1 = 1 To Range("A1").CurrentRegion.Rows.Count - 1 Step 2   'For loop die in stapjes van twee de rijen van Blad1 verwerkt.
            r2 = (r1 - 1) \ 2 + 1               'rij op werkblad 2 bepalen
            a = Split(Cells(r1, 1), " ")        'splits rij op spatie
            b = Split(Cells(r1 + 1, 1), " ")    'splits rij op spatie
            .Cells(r2, 1) = a(0)                'eerste element van a komt in rij r2, kolom A van Blad2
            .Cells(r2, 2) = a(1)                'tweede element van a
            .Cells(r2, 3) = a(2) & " " & a(3) & " " & a(4)  '3e + 4e + 5e element van a komt in kolom C, gescheiden door spaties
            i = 5
            Do While a(i) <> "BV"               'alle volgende elementen van a <> "BV" komen in kolom D, gescheiden door spaties
                .Cells(r2, 4) = .Cells(r2, 4) & a(i) & " "
                i = i + 1
            Loop
           .Cells(r2, 4) = Trim(.Cells(r2, 4))  'spatie aan het einde wissen
            For k = i To UBound(a) - 1          'alle volgende elementen van a behoudens het laatste komen in kolom E, gescheiden door spaties
                .Cells(r2, 5) = .Cells(r2, 5) & a(k) & " "
            Next
            .Cells(r2, 5) = Trim(.Cells(r2, 5)) 'spatie aan het einde wissen
            .Cells(r2, 6) = a(UBound(a))        'het laatste element van a komt in kolom F
            If UBound(b) = 4 Then               'als even regel uit 5 elementen bestaat dan de eerste 2 in kolom G en de rest in kolom H
                .Cells(r2, 7) = b(0) & " " & b(1)
                .Cells(r2, 8) = b(2) & " " & b(3) & " " & b(4)
            Else                               'als even regel uit 4 elementen bestaat ("kampioen" i.p.v. "2e plaats") dan de eerste in kolom G en de rest in kolom H
                .Cells(r2, 7) = b(0)
                .Cells(r2, 8) = b(1) & " " & b(2) & " " & b(3)
            End If
        Next
        .Columns("A:H").EntireColumn.AutoFit    'pas de kolommen aan aan de langste tekst
    End With
End Sub

 

[JEC.]

Hier nog een andere methode met regular expression

Sub jec()
 Dim ar, it, j As Long, x As Long
 ar = Cells(1).CurrentRegion.Resize(, 9)
 With CreateObject("vbscript.regexp")
   .Pattern = "(NTL) (\d{4}) (\de \w+ \D) (.*?) (BV \D+|\w+ BV) (\d+)"
    For j = 1 To UBound(ar) Step 2
      If .test(ar(j, 1)) Then
        For Each it In .Execute(ar(j, 1))(0).submatches
           ar(j, x + 2) = it
           x = x + 1
        Next
        ar(j, 8) = Left(ar(j + 1, 1), InStrRev(ar(j + 1, 1), "e D") - 3)
        ar(j, 9) = Replace(ar(j + 1, 1), ar(j, 8) & " ", "")
      End If
      x = 0
    Next
 End With
 Cells(1).CurrentRegion.Offset(20).Resize(, 9) = ar
End Sub

 

[RoVo1211]

@AHulpje: Hartelijk dank voor de uitleg.
Ik heb nog 1 andere vraag. Ik hoop dat je me niet vervelend begint te vinden.
Bij de poules heb ik ook een poule die bestaat uit één woord. De poule kan dus bestaan uit 1 woord (Eredivisie) of 3 woorden ("1e Divisie A" t/m "3e Divisie E"). Hoe kan de code worden aangepast zodat het woord "Eredivisie" separaat in kolom C komt te staan?

Bij de resultaten van vorig seizoen heb ik soortgelijk issue, maar daar ben ik zelf al aan het puzzelen geweest en ben op de goede weg om dat probleem te tackelen.

Dat gedeelte van de code heb ik als volgt aangepast:

If UBound(b) = 2 Then                               'als even regel uit 2 elementen bestaat dan de eerste  in kolom G en de 2e in kolom H ("Kampioen Eredivsie")
                .Cells(r2, 7) = b(0)
                .Cells(r2, 8) = b(1)
            ElseIf UBound(b) = 3 Then            'als even regel uit 3 elementen bestaat dan de eerste 2 in kolom G en de laatste in kolom H ("2e plaats Eredivisie" )
                .Cells(r2, 7) = b(0) & " " & b(1)
                .Cells(r2, 8) = b(2)
            ElseIf UBound(b) = 4 Then            'als even regel uit 4 elementen bestaat dan de eerste in kolom G en de rest in kolom H ("kampioen 1e Divisie A")
                .Cells(r2, 7) = b(0)
                .Cells(r2, 8) = b(1) & " " & b(2) & " " & b(3)
            ElseIf UBound(b) = 5 Then           'als even regel uit 5 elementen bestaat dan de eerste 2 in kolom G en de rest in kolom H ("2e plaats 1e Divisie A")
                .Cells(r2, 7) = b(0) & " " & b(1)
                .Cells(r2, 8) = b(2) & " " & b(3) & " " & b(4)
            End If

Om te ontdekken uit hoeveel elementen de even regel bestaat heb ik de volgende macro geschreven.
De originele data staan in sheet 8, vandaar dat ik begin met "With Sheets(8)".

With Sheets(8)
        For r1 = 1 To Range("A1").CurrentRegion.Rows.Count - 1 Step 2  
            a = Split(Cells(r1, 1), " ")                                'splits oneven rij op spatie
            b = Split(Cells(r1 + 1, 1), " ")                         'splits even rij op spatie
            .Cells(r1 + 1, 9) = b(UBound(b))
        Next
    End With

Zie bijlage voor het resultaat en mijn vragen daarover.

 

[RoVo1211]

@jec: Bedankt voor het meedenken, maar ik krijg een foutmelding bij de regel:

ar(j, 8) = Left(ar(j + 1, 1), InStrRev(ar(j + 1, 1), "e D") - 3)

De foutmelding is: "Ongeldige procedure-aanroep of ongeldig argument".
Ik probeer te begrijpen wat er staat, maar dit is hogere wiskunde voor me. Zou je willen uitleggen wat de stappen behelzen?

 

[AHulpje]

De index van een array begint met 0, dus a(0) is het eerste element van de array a.
Ubound(a) levert de hoogste index van de array op, voor een array van 5 elementen is dat dus 4, de telling begint immers met 0.
Om de "even regels" op de juiste wijze te kunnen splitsen moet gekeken worden naar het aantal elementen:
Kampioen Eredivisie 2 elementen
7e plaats Eredivisie 3 elementen
Kampioen 2e Divisie C 4 elementen
6e plaats 1e Divisie A 5 elementen

Zijn er meer mogelijkheden die op hetzelfde aantal elementen uitkomen?
Zo ja, dan zou ook naar de betekenis van die elementen gekeken moeten worden, met name "Eredivisie" en "Kampioen".
Kom je er niet uit laat dat dan even weten.

 

[JEC.]

Zou wel moeten werken. In de bijlage ook niet?

 

[JEC.]

Als je commentaar bij codes wilt hebben, kun je de gehele code in ChatGpt zetten en vragen om comments per regel. Heel handig.

 

[JEC.]

Gezien je laatst geplaatste bestand:

Sub jec()
 Dim ar, it, j As Long, x As Long
 ar = Cells(1).CurrentRegion.Resize(, 9)
 With CreateObject("vbscript.regexp")
   .Pattern = "(NTL) (\d{4}) (\de \w+ \D) (.*?) (BV \D+|\w+ BV) (\d+)"
    For j = 1 To UBound(ar) Step 2
      If .test(ar(j, 1)) Then
        For Each it In .Execute(ar(j, 1))(0).submatches
           ar(j, x + 2) = it
           x = x + 1
        Next
        ar(j, 8) = Left(ar(j + 1, 1), InStrRev(ar(j + 1, 1), " ", InStr(ar(j + 1, 1), "e D") + InStr(ar(j + 1, 1), "Ere")))
        ar(j, 9) = Replace(ar(j + 1, 1), ar(j, 8), "")
      End If
      x = 0
    Next
 End With
 Cells(1).CurrentRegion.Resize(, 9) = ar
End Sub

 

[RoVo1211]

@jec: Zoals je had aangegeven heb ik de code in ChatGPT gezet en kreeg dit als antwoord:

It looks like you're trying to extract specific patterns from a range of cells in Excel using VBA. This code snippet seems to be using regular expressions to parse text and then populate another range with the extracted information. However, it's not entirely clear what your question or issue is.

Could you please provide more context or specify what you need help with regarding this VBA code?

Met alle respect: daar word ik niets wijzer van.
Graag zie ik een uitleg van de code van jouw kant.

 

[JEC.]

Je hebt zeker alleen de code geplakt? Zonder de vraag te stellen

 

[JEC.]

Dit zegt chatgpt als je de vraag correct stelt...

Sub jec()
 ' Declaratie van variabelen
 Dim ar, it, j As Long, x As Long
 
 ' Definieer het bereik van de array
 ar = Cells(1).CurrentRegion.Resize(, 9)
 
 ' Maak een object aan voor reguliere expressies
 With CreateObject("vbscript.regexp")
   ' Definieer het patroon voor de reguliere expressie
   .Pattern = "(NTL) (\d{4}) (\de \w+ \D) (.*?) (BV \D+|\w+ BV) (\d+)"
 
   ' Loop door de array in stappen van 2
   For j = 1 To UBound(ar) Step 2
     ' Controleer of het patroon overeenkomt met de celinhoud
     If .test(ar(j, 1)) Then
       ' Extractie van submatches en invullen van de array
       For Each it In .Execute(ar(j, 1))(0).submatches
          ar(j, x + 2) = it
          x = x + 1
       Next
       ' Extra bewerkingen op de cellen
       ar(j, 8) = Left(ar(j + 1, 1), InStrRev(ar(j + 1, 1), " ", InStr(ar(j + 1, 1), "e D") + InStr(ar(j + 1, 1), "Ere")))
       ar(j, 9) = Replace(ar(j + 1, 1), ar(j, 8), "")
     End If
   
     ' Reset de teller x
     x = 0
   Next
 End With
 
 ' Terugplaatsen van de bewerkte array naar het werkblad
 Cells(1).CurrentRegion.Resize(, 9) = ar
End Sub

• Sub jec(): Dit definieert een VBA-subroutine genaamd "jec".
• Dim ar, it, j As Long, x As Long: Dit declareert de variabelen ar, it, j en x. Merk op dat alleen j van het type Long is; de anderen zijn standaard varianten.
• ar = Cells(1).CurrentRegion.Resize(, 9): Dit wijst het bereik van de array ar toe aan het huidige regio van de actieve cel en zorgt ervoor dat het 9 kolommen breed is.
• With CreateObject("vbscript.regexp"): Dit opent een blok waarin we een object maken voor reguliere expressies.
• .Pattern = "(NTL) (\d{4}) (\de \w+ \D) (.*?) (BV \D+|\w+ BV) (\d+)": Dit stelt het patroon in voor de reguliere expressie die we zullen gebruiken om tekst te matchen en te extraheren.
• For j = 1 To UBound(ar) Step 2: Dit start een lus die door de array ar loopt, waarbij wordt overgeslagen van één element.
• If .test(ar(j, 1)) Then: Dit controleert of het patroon overeenkomt met de celinhoud.
• For Each it In .Execute(ar(j, 1))(0).submatches: Dit haalt submatches op die overeenkomen met het patroon en vult de array ar met deze waarden.
• ar(j, 8) = Left(ar(j + 1, 1), InStrRev(ar(j + 1, 1), " ", InStr(ar(j + 1, 1), "e D") + InStr(ar(j + 1, 1), "Ere"))): Dit voert extra bewerkingen uit op de cellen en vult een specifieke cel in de array.
• ar(j, 9) = Replace(ar(j + 1, 1), ar(j, 8), ""): Dit vervangt een deel van de inhoud van een cel in de array.
• x = 0: Dit reset de teller x.
• Next: Dit geeft aan het einde van de lus aan.
• Cells(1).CurrentRegion.Resize(, 9) = ar: Dit plaatst de bewerkte array terug op het werkblad.

Uitleg van het regex patroon:
(NTL) (\d{4}) (\de \w+ \D) (.*?) (BV \D+|\w+ BV) (\d+)

• (NTL): Dit matcht letterlijk de tekens "NTL".
• (\d{4}): Dit matcht vier opeenvolgende cijfers.
• (\de \w+ \D): Dit matcht een specifiek formaat van tekst bestaande uit een cijfer gevolgd door een spatie, gevolgd door een of meer woordtekens, gevolgd door iets anders dan een cijfer.
• (.*?): Dit is een niet-grijpende groep die alles matcht, maar zo min mogelijk tekens, totdat de volgende delen van het patroon gematcht kunnen worden. Dit wordt gebruikt voor flexibiliteit in het matchen van variabele lengtes van tekst.
• (BV \D+|\w+ BV): Dit matcht ofwel "BV" gevolgd door een of meer niet-cijfer tekens, ofwel een of meer woordtekens gevolgd door "BV".
• (\d+): Dit matcht een of meer opeenvolgende cijfers.

Zoals je ziet doet hij dit perfect, scheelt enorm veel tijd als je langere codes van comments wilt voorzien. Het regex patroon wordt zelfs helemaal uitgekleed als je er om vraagt.

 

[snb]

Of zó:

Sub M_snb()
   sn = Cells(1).CurrentRegion
  
   For j = 1 To UBound(sn) Step 2
    c00 = Replace(Replace(Replace(sn(j, 1), " ", "_", , 2), " BV ", "_BV "), Right(sn(j, 1), 6), Replace(Right(sn(j, 1), 6), " ", "_"))
    sn(j, 1) = Left(c00, 21) & "_" & Mid(c00, 23) & Left("_" & sn(j + 1, 1), Len(sn(j + 1, 1)) - 12) & "_" & Right(sn(j + 1, 1), 12)
    sn(j + 1, 1) = ""
   Next
  
   Cells(10, 1).Resize(UBound(sn)) = sn
   Cells(10, 1).Resize(UBound(sn)).TextToColumns , 1, , , 0, 0, 0, 0, 1, "_"
End Sub

 

[JEC.]

Geeft alleen niet de juiste output. Zie onder de rode streep

 

[RoVo1211]

Ik weet dat er uitzonderingen zijn in de namen van 2 bowlingvereningingen (BV['s]), t.w. Asser BV en de Nieuwegeinse BV. Voor deze 2 moet een uitzondering gemaakt worden met een if-statement, zoiets als

if right(sn(j,1),2) = "BV" then
....
else
    c00 = Replace(Replace(Replace(sn(j, 1), " ", "_", , 2), " BV ", "_BV "), Right(sn(j, 1), 6), Replace(Right(sn(j, 1), 6), " ", "_"))
    sn(j, 1) = Left(c00, 21) & "_" & Mid(c00, 23) & Left("_" & sn(j + 1, 1), Len(sn(j + 1, 1)) - 12) & "_" & Right(sn(j + 1, 1), 12)
    sn(j + 1, 1) = ""

end if

Hoe de algebra voor de uitzondering (....) geformuleerd moet worden, kom ik even niet uit.

 

[RoVo1211]

Hoe de algebra voor de uitzondering (....) geformuleerd moet worden, kom ik even niet uit.

De namen van de BV'en heb ik overgeslagen omdat ik in Access en aparte tabel heb met BV-nrs en BV-namen (BV=bowlingvereniging).

@AHulpje: ik heb jouw code uit #6 aangepast aan zoveel mogelijk regels, echter toen ik deze wilde testen kreeg ik de foutmelding "Next zonder For".
Ik heb het gewijzigde bestand als zip-bestand toegevoegd. Als je het .bas-bestand opent in een programma als notepad++ zie je dat de For...Next-lus begint op regel 8 en eindigt op regel 57.
Waarom krijg ik dan toch de foutmelding dat de "For"-component ontbreekt?