• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

namen zoeken

Status
Niet open voor verdere reacties.
Nee, die is niet veranderd. De opdracht van de macro is om de namen uit kolom B en C in een blad te zetten dat correspondeert met de in kolom P genoemde teams.

In blad "A1" komen in kolom A de namen van de mannen te staan van het blad "Teamindeling (kolom B & C, als kolom D = "M") en in kolom B de namen van de vrouwen (kolom B & C, als kolom D = "V")
Idem de namen van "Teamindeling" uit kolom P = "B1" in tabblad "B1" enz.

De fout ontstond volgens mij toen ik een aantal spelers in "Teamindeling", kolom P een aantal spelers bij "Mi" (Midweek) had ingedeeld en de optie "Mi" in de macro heb toegevoegd.

Wat ik niet uitsluit is dat ik in kolom P ergens achter de team-afkorting een spatie heb toegevoegd. Kan het daardoor vastlopen?
 

Bijlagen

  • kolommen.jpg
    kolommen.jpg
    82,9 KB · Weergaven: 71
R0bert zei:
Wat ik niet uitsluit is dat ik in kolom P ergens achter de team-afkorting een spatie heb toegevoegd. Kan het daardoor vastlopen?
Klik om te vergroten...
Dat zou best wel eens kunnen.
Deze fout zou je moeten kunnen afvangen door de rode coderegel aan te passen:
Code: 
Private Sub CommandButton1_Click()
Dim sn, arr, cl, j As Long, x As Long
Application.ScreenUpdating = False
sn = Sheets("Teamindeling").Cells(1).CurrentRegion
For Each cl In Array("A1", "A2", "B1", "Mi")
ReDim arr(1, 0)
 For j = 1 To UBound(sn)
      [COLOR="#FF0000"]If Trim(sn(j, 16)) = cl Then[/COLOR]
          x = sn(j, 4) = "V"
          arr(Abs(x), UBound(arr, 2)) = sn(j, 2) & " " & sn(j, 3)
          ReDim Preserve arr(1, UBound(arr, 2) + 1)
       End If
     Next j
 With Sheets(cl)
   .Cells(1).CurrentRegion.ClearContents
   .Cells(1).Resize(UBound(arr, 2), 2) = Application.Transpose(arr)
   .Columns(1).Resize(, 2).SpecialCells(4).Delete
 End With
  Erase arr
  Next cl
End Sub
De instructie Trim is toegevoegd.
 
Ik heb de coderegel aangepast. De foutmelding bleef echter:
.Cells(1).Resize(UBound(arr, 2), 2) = Application.Transpose(arr)

Toch weet ik nu waar het aan ligt: Omdat de indeling van spelers nog verfijnd moet worden, heb ik (als voorbeeld) alle A-spelers in blad "Teamindeling" in kolom P onder "A1" gezet. Dat is nu een selectiegroep, splitsing in team A1 en team A2 vind later plaats. Maar daardoor ontbreekt nu de aanduiding "A2" in kolom P. Daar kan de macro kennelijk niet tegen.
Pro forma heb ik een speler weer bij de A2 gezet en toen liep de macro wel door!

Is er een trucje te bedenken waardoor de macro gewoon doorloopt als in de macroregel "For Each cl In Array("A1", "A2", "B1", "B2", "B3", "B4", (enz)" een bepaald team in kolom P ontbreekt?
 
Ik heb het hier en daar wat aangepast.
Code: 
Private Sub CommandButton1_Click()
Dim sn, arr, cl, cll As Range, j As Long, x As Long, c00 As String
Application.ScreenUpdating = False
sn = Sheets("Teamindeling").Cells(1).CurrentRegion
For Each cll In Columns(16).SpecialCells(2).Offset(1).SpecialCells(2)
 If InStr(c00, cll) = 0 Then c00 = c00 & "|" & cll
Next cll
For Each cl In Split(Mid(c00, 2), "|")
ReDim arr(1, 0)
 For j = 1 To UBound(sn)
      If sn(j, 16) = cl Then
          x = sn(j, 4) = "V"
          arr(Abs(x), UBound(arr, 2)) = sn(j, 2) & " " & sn(j, 3)
          ReDim Preserve arr(1, UBound(arr, 2) + 1)
       End If
     Next j
     If UBound(arr, 2) > 0 Then
     If IsError(Evaluate("'" & cl & "'!A1")) Then Sheets.Add(, Sheets(Sheets.Count)).Name = cl
        With Sheets(cl)
          .Cells(1).CurrentRegion.ClearContents
          .Cells(1).Resize(UBound(arr, 2), 2) = Application.Transpose(arr)
          If arr(0, 0) <> "" Or arr(0, 1) <> "" Then
           On Error Resume Next
              .Columns(1).Resize(, 2).SpecialCells(4).Delete
            Else
              .Columns(2).SpecialCells(4).Delete
            On Error GoTo 0
          End If
        End With
    End If
  Erase arr
  Next cl
End Sub
 
Teamindeling vervolg

Ik stel de hulp die ik op dit forum krijg enorm op prijs!!
Zo jammer dat ik de kennis niet heb om deze VB code te doorgronden. De VB-cursus die ik via Youtube volg heeft me al wel wat basiskennis gebracht, maar dit gaat me nooit lukken. Maar goed, met zo'n forum hoeft dat ook niet echt! :D

Ik heb de nieuwe code uiteraard direct geprobeerd. Deze geeft een foutmelding bij de volgende (bij foutopsporing geel gearceerde) regel: .Columns(2).SpecialCells(4).Delete
Het zal je niet verbazen dat ik daar geen oplossing voor heb..... Maar jij misschien wel?
 
Het zou niet mogelijk moeten zijn daar een foutmelding te verkrijgen.
Er staat nl een 'on error resume next' voor.

Laat het bestand eens zien zoals jij die fout verkrijgt.
 
Kan je met bijgevoegde printscreen uit de voeten of moet ik het betreffende Excelbestand opnemen?
 

Bijlagen

  • fout-3.jpg
    fout-3.jpg
    103,5 KB · Weergaven: 65
@hsv.
De volgorde in de if-then-else-reeks klopt volgens mij niet.
Ik denk zo:
Code: 
...
    On Error Resume Next
    If arr(0, 0) <> "" Or arr(0, 1) <> "" Then
        .Columns(1).Resize(, 2).SpecialCells(4).Delete
    Else
        .Columns(2).SpecialCells(4).Delete
    End If
    On Error GoTo 0
...
 
Dat moet het zijn @Timshel (overheen gekeken).
 
Geniaal! Alles loopt nu als een zonnetje.
Beetje jammer dat ik het niet kan bevatten, maar het resultaat is echt top!
Hartstikke bedankt!!

Groeten
Rob
 
tussenvoegsels

De VBA code doet het zo goed, dat ik er met mijn lekenverstand niet aan durf te komen.
Toch zou ik graag nog een verbetering aanbrengen.
In het huidige werkblad staan de voornamen in kolom 2 en de achternamen met tussenvoegsels in kolom 3. Dus: Jan (kolom 2); Werf, van de (kolom 3)
De VBA code zet de juiste namen in het juiste tabblad, maar uiteraard geschreven als "Jan Werf, van de"
Ik wil in het blad "Teamindeling" graag een kolom met de tussenvoegsels toevoegen: kolom 2 = Jan, kolom 3 = van de, kolom 4 is Werf.
Op welke regel(s) moet de code worden aangepast om het juiste resultaat te krijgen?
De goed lopende code met 2 naam-kolommen heb ik als bijlage aangehecht.
Bekijk bijlage Code_Teamindeling.txt
 
Plaats het gewijzigd bestand met de code, dan zal ik er weer eens induiken.
 
Het lukt me niet om het originele bestand als bijlage toe te voegen; het is te groot (105 kb).
Daarom heb ik het grootste deel van de data verwijderd, de resterende regels heb ik wat betreft de indeling willekeurig verdeeld over de verschillende teams.
In werkelijkheid slaat dat nergens op, maar de structuur blijft het zelfde.
Hopelijk kan je de oorspronkelijke code zo aanpassen, dat de gegevens van kolom B & C & D worden opgenomen in de betreffende team-tabbladen.
Bekijk bijlage Testbestand-2.xlsm
 
De blauwe regel is de aangepaste regel.
Waarom ik met de functie Trim de overtollige spatie niet weg krijg??

Code: 
x = sn(j, 4) = "V"
[COLOR=#0000ff] arr(Abs(x), UBound(arr, 2)) = sn(j, 2) & IIf(Len(sn(j, 3)) > 0, " " & sn(j, 3), "") & " " & sn(j, 4)[/COLOR]
 ReDim Preserve arr(1, UBound(arr, 2) + 1)
 
Ja hoor, dat is het!
De code werkte eerst niet helemaal goed omdat werd gekeken naar de oude teamindeling (kolom P), maar de nieuwe teamindeling is door de extra kolom Q geworden. Ik heb daarom "16" veranderd in "17"
Ook het in de 2e kolom zetten van de dames werkte door de toegevoegde kolom niet meer. Ik heb de regel met "V" de 4 gewijzigd in 5.
En jawel, nu gaat het weer goed. Ik begin het zowaar te leren!
Dank voor je hulp!!
Mijn aanpassingen:
eDim arr(1, 0)
For j = 1 To UBound(sn)
If sn(j, 17) = cl Then
x = sn(j, 5) = "V"

Groeten,
Rob
 
In de code voor de teamindeling zit iets niet helemaal goed.
Eerder werd een worksheet / tabblad toegevoegd als in de te verdelen kolom (Q, dus 17) een "onbekend" team werd genoemd. (If IsError(Evaluate("'" & cl & "'!A1")) Then Sheets.Add(, Sheets(Sheets.Count)).Name = cl)

Nu gaat een aantal spelers uit de senioren groep (S1, S2 enz) in een "Midweek team" spelen. Bij de betreffende spelers heb ik de teamaanduiding van kolom 17 gewijzigd in "M".
Na het uitvoeren van de code wordt echter geen tabblad "M" aangemaakt en de betreffende spelers vind ik ook elders niet meer terug.
Ik heb handmatig een tabblad "M" aangemaakt, maar ook dan worden de betreffende spelers daar niet in geplaatst.

Ik heb een testbestand gemaakt met 2 spelers in elk team.
Bij uitvoeren van de code blijkt dat meerdere teamaanduidingen worden genegeerd: De tabbladen A1, B4, C1, C4, E1, F1 en M blijven leeg.

Ik vrees dat ik bij de aanpassing van de code aan de toegevoegde kolom 3 (de tussenvoegsels tussen voor- en achternaam) iets niet goed heb gedaan.

En het ging allemaal zo lekker...
Ik hoop dat je me nog een keer wilt / kunt helpen!!

Bekijk bijlage Code_Teamindeling 3 juni.txt
Bekijk bijlage Teamindeling test 3 juni.xlsm
 
Je bent één dingetje vergeten aan te passen.

Code: 
For Each cll In Columns([COLOR="#FF0000"]17[/COLOR]).SpecialCells(2).Offset(1).SpecialCells(2)
 
Ai!! Dat krijg je als je als amateur in een bestand van een pro gaat zitten prutsen!
Afijn, het is nu opgelost, dank daarvoor!
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan