1 Lijst maken uit gegevens van meerdere tabbladen.

[Andre175]

Goedemorgen


Ik heb een bestand met 2 Tabbladen, "Ladder" en "Kids".
Nadat de opgave lijsten gedownload worden van een website waar iedereen zich kan opgeven voor verschillende evenementen, wordt per evenement een tabblad toegevoegd.
Deze gegevens moeten verwerkt worden.
In het voorbeeldbestand is in de tabbladen zonder kleur te zien hoe de lijsten gedownload worden.
Ieder gedownloade lijst komt op 1 tabblad, welke de naam krijgt van het evenement.
Van de 2 rode tabbladen heb ik van de lijsten handmatig een tabel gemaakt, het handmatig iets moeten wijzigen wil ik uiteraard graag vermijden.

Nu is het mijn bedoeling dat ieder evenement een IDnummer krijgt, dit gebeurt op tabblad "Ladder"
De namen van alle tabbladen worden in kolom B gezet en vervolgens genummerd. (dit werkt wel, wordt in later stadium uitgebreid)

Vervolgens op tabblad "Kids" wil ik graag een lijst met namen maken van wie zich heeft opgegeven.
Hier loop ik enigszins vast.
Wanneer de gegevens op de diverse tabbladen in een tabel staan lukt het kopiëren wel, staan de gegevens niet in tabelvorm dan lukt het me niet.

Sub OpgaveKids()
    With Sheets("Kids")
        s = .Range("Tbl_Kids").ListObject.ListRows.Count + 1
        If s = 1 Then GoTo slaover
        .Range("B2:H" & s).ClearContents
        .ListObjects("Tbl_Kids").Resize Range("$B$1:$H$2")
slaover:

    For i = 3 To Sheets.Count
    
        For j = 2 To Sheets(i).ListObjects(1).ListRows.Count + 1            'aantal te kopiëren rijen bepalen
            jj = .ListObjects(1).ListRows.Count + 2                                 'om eerste lege rij te bepalen op blad "Kids"
                .Range("B" & jj) = Sheets(i).Range("B" & j)                       'gegevens overzetten
                .Range("C" & jj) = Sheets(i).Range("C" & j)
                .Range("D" & jj) = Sheets(i).Range("D" & j)
                .Range("E" & jj) = Sheets(i).Range("E" & j)
                .Range("F" & jj) = Sheets(i).Range("F" & j)
                .Range("G" & jj) = Sheets(i).Range("G" & j)
                .Range("H" & jj) = Sheets(i).Range("H" & j)
            jj = jj + 1                                                                     'volgende lege regel
        Next j                                                                               'volgende te kopiëren regel
    Next i
    End With
End Sub

Als alle gegevens in 1 lijst gezet zijn wordt de volgende stap het verwijderen van identieke regels.
Daarna bij ieder kind het ID nummer van het opgegeven evenement in kolom I zetten (2e opgave in kolom J, 3e in kolom K...enz)

Maar nu eerst het probleem waar ik nu tegen aan loop maar eens, wanneer de gegevens in een tabel staan lukt het kopiëren wel, staan de gegevens niet in tabelvorm dan lukt het me niet.

 

[snb]

Gebruik altijd kolom 1.

Sub M_snb()
    On Error Resume Next
    With Sheets("Kids")
       .Cells(1).Select
       .ListObjects.Add , , , 1, .Cells(1).CurrentRegion
    End With
    
    For Each it In Sheets
      If InStr("LadderKids", it.Name) = 0 Then
        With it.UsedRange
            Blad17.Cells(Rows.Count, 1).End(xlUp).Resize(.Rows.Count, .Columns.Count - 1) = .Offset(1, 1).Value
          End With
      End If
    Next
End Sub

 

[Andre175]

Bedankt SNB, een andere opzet, maar het werkt.
Ik zal het later eens bestuderen hoe het excact werkt, nu ff geen tijd voor.
Eerst maar verder met het filteren van dezelfde namen...
Namenlijst voorzien van ID nummers....(ieder kind eigen ID)
dan de ID nummers van de opgegeven evenementen achter de namen.

Zien dat ik het voor zaterdag as klaar heb. (moet tussen alle andere bezigheden door)

Het is niet mijn gewoonte dit hier te vragen, maar als iemand een helpende hand kan geven gezien de tijdsdruk, dan ben ik diegene zeer dankbaar

 

[Andre175]

dacht dat het niet zo lastig zou zijn de dubbele gegevens eruit te halen.

Met de functie "Dubbele waarden verwijderen" en dan de kolommen "Voornaam", "Achternaam" en "E-mailadres" selecteren gaat het ook prima.
Echter wanneer een macro opneem, en het resultaat in de code meeneem, worden er geen dubbele waarden verwijderd.

de volgende code heb ik toegevoegd:

Sub LijstKids()
    With Sheets("Kids")
        s = .Range("Tbl_Kids").ListObject.ListRows.Count + 1
        If s = 1 Then GoTo slaover
        .Range("A2:H" & s).ClearContents
        .ListObjects("Tbl_Kids").Resize Range("$A$1:$G$2")
slaover:
    End With
'    Exit Sub
    On Error Resume Next
    With Sheets("Kids")
       .Cells(1).Select
       .ListObjects.Add , , , 1, .Cells(1).CurrentRegion
    End With
    
    For Each it In Sheets
      If InStr("LadderKids", it.Name) = 0 Then
        With it.UsedRange
            Blad17.Cells(Rows.Count, 1).End(xlUp).Resize(.Rows.Count, .Columns.Count - 1) = .Offset(1, 1).Value
          End With
      End If
      Next
    
[B]    Sheets("Kids").Range("Tbl_Kids[#Alles]").RemoveDuplicates Columns:=Array(1, 2, 5), Header:=xlYes[/B]
End Sub

Er wordt gewoon niets verwijderd, terwijl er toch echt dubbel gegevens in staan.

run ik de opgenomen macro...

Sub Knop6_Klikken()

    Range("G6").Select
    ActiveSheet.Range("Tbl_Kids[#Alles]").RemoveDuplicates Columns:=Array(1, 2, 5) _
        , Header:=xlYes
End Sub

dan foutmelding:

 

[HSV]

Probeer eens...

 Sheets("Kids").listobjects("[B]Tbl_Kids").databodyrange[/B].RemoveDuplicates Array(1, 2, 5), xlYes

 

[snb]

En verwijder vooral:

   With Sheets("Kids")
        s = .Range("Tbl_Kids").ListObject.ListRows.Count + 1
        If s = 1 Then GoTo slaover
        .Range("A2:H" & s).ClearContents
        .ListObjects("Tbl_Kids").Resize Range("$A$1:$G$2")
slaover:
    End With
'    Exit Sub

 

[Andre175]

HSV.... Bedankt..

weer een stap verder.

blijf het wel vreemd vinden, neem je een macro op, die op dat moment werkt.
Vul ik de code in in mijn eigen macro, dan werkt ie ineens niet meer.

na ja, later maar uitzoeken.

nu eerst verder

 

[Andre175]

@ SNB....

dat stukje code had ik erin gezet om de oude lijst te verwijderen wanneer deze vernieuwd wordt....
maar zal het eens zonder proberen


Heb het geprobeerd.
als ik dat stukje code weg laat, en ik maak handmatig een wijziging in 1 van de namen op een tabblad wat gedownload is van de website, dan wordt de lijst niet aangepast wanneer ik de code opnieuw run.
Laat ik het stukje code wel meedraaien, da wordt de lijst wel juist weergegeven.

waar het aan ligt, probeer ik later wel uit te zoeken, nu eerst verder.

 

[Andre175]

Poosje aan het puzzelen geweest om de opgegeven evenementen achter ieder kind te zetten......

Kolom H = opgave 1
Kolom I = opgave 2
enz....

Ik denk dat ik aardig op weg ben.....

Sub EvenementenOpgave()

    Set sh1 = Sheets("Kids")
    Set sh2 = Sheets("Ladder")
    
    
    ar1 = sh1.Range("A2:O100")
    For i = 3 To Sheets.Count
        
        For j = 1 To sh1.ListObjects(1).ListRows.Count
            For jj = 2 To Sheets(i)[COLOR="#FF0000"].DataBodyRange.[/COLOR]ListRows.Count
                ar2 = Sheets(i).Range("A1:H50")
                If ar1(j, 1) = ar2(jj, 2) Then
                    sh1.Range("H" & j + 1).Value = ar2(j, 1)
                End If
            Next jj
        Next j
    Next i

End Sub

De rode tekst in de code geeft foutmelding.... het is geen tabel....



nu eerst maar de ogen dicht, morgen weer een dag

 

[Andre175]

ik ben weer een stap verder

Het zoeken en vergelijken gaat bijna goed.

Alleen het resultaat wegzetten in de juiste kolom nog niet.
Alle resultaten komen in dezelfde kolom, terwijl het de bedoeling is dat wanneer er in het volgende tabblad (evenement) wordt gezocht, dat het resultaat ook in 1 kolom naar rechts wordt genoteerd.

Dus:
Evenement 1 in Kolom H
Evenement 2 in Kolom I
Evenement 3 in Kolom J
enz....

Sub EvenementenOpgave()

    Set sh1 = Sheets("Kids")
    Set sh2 = Sheets("Ladder")
    
    
    ar1 = sh1.Range("A2:O100")
    For i = 3 To Sheets.Count
        
        For j = 1 To sh1.Range("A" & Rows.Count).End(xlUp).Row
            For jj = 2 To Sheets(i).Range("A" & Rows.Count).End(xlUp).Row
                ar2 = Sheets(i).Range("A1:H50")
                If ar1(j, 1) = ar2(jj, 2) Then
                    [COLOR="#FF0000"]sh1.Range("H" & j + 1).Value[/COLOR] = ar2(jj, 1)
                End If
            Next jj
        Next j
    Next i
End Sub

Voor het stukje code sh1.Range("H" & j + 1).Value zal dus iets anders moeten komen.
Wanneer i met 1 wordt verhoogd, dan zal de Kolom aanduiding 1 naar rechts moeten gaan.

Edit:
opgelost

 Set sh1 = Sheets("Kids")
    Set sh2 = Sheets("Ladder")
    
    
    ar1 = sh1.Range("A2:O100")
    For i = 3 To Sheets.Count
        
        For j = 1 To sh1.Range("A" & Rows.Count).End(xlUp).Row
            For jj = 2 To Sheets(i).Range("A" & Rows.Count).End(xlUp).Row
                ar2 = Sheets(i).Range("A1:H50")
                If ar1(j, 1) = ar2(jj, 2) Then
                    sh1.Cells(j + 1, i + 5).Value = ar2(jj, 1)
                End If
            Next jj
        Next j
    Next i

 

[Andre175]

Ik heb de code nu bijna zoals ik het graag hebben wil.
Echter aan het eind van de lijst gaat er iets niet zoals het hoort.



Na de laatste naam worden de evenementen trapsgewijs weg gezet.
Iemand een idee hoe dit kan?

tssss... ik stel de vraag en dan schiet me het antwoord te binnen.
Omdat de array een regel minder heeft dan wat voor j en jj bepaald wordt.
MAW.... het aantal regels bepalen en er dan 1 afhalen(zie correctie in rood in code)

Sub LijstKids()
    Application.ScreenUpdating = False

    On Error Resume Next
    With Sheets("Kids")
       .Cells(1).Select
       .ListObjects.Add , , , 1, .Cells(1).CurrentRegion
    End With
    
    For Each it In Sheets
      If InStr("LadderKids", it.Name) = 0 Then
        With it.UsedRange
            Sheets("Kids").Cells(Rows.Count, 1).End(xlUp).Resize(.Rows.Count, .Columns.Count - 2) = .Offset(1, 2).Value
          End With
      End If
      Next
    
    Sheets("Kids").ListObjects("Tbl_Kids").DataBodyRange.RemoveDuplicates Array(1, 2, 5), xlYes
    
    
    Set sh1 = Sheets("Kids")
    Set sh2 = Sheets("Ladder")
    
    
    ar1 = [B]sh1.Range("A2:O200")[/B]
    For i = 3 To Sheets.Count
        
        For j = 1 To sh1.Range("A" & Rows.Count).End(xlUp).Row [COLOR="#FF0000"]- 1[/COLOR]
            For jj = 1 To Sheets(i).Range("A" & Rows.Count).End(xlUp).Row [COLOR="#FF0000"]- 1[/COLOR]
                ar2 = Sheets(i).Range("A2:H50")
                If ar1(j, 1) = ar2(jj, 3) And ar1(j, 2) = ar2(jj, 4) And ar1(j, 5) = ar2(jj, 7) Then
                    sh1.Cells(j + 1, i + 5).Value = Sheets(i).Name
                End If
            Next jj
        Next j
    Next i
    Application.ScreenUpdating = True
End Sub

ar1 = sh1.Range("A2:O200")
Ik denk dat hiervoor wel wat anders kan/moet.
Als er meer kinderen zich opgeven (nu ongeveer 150, was wel eens 250), dan is deze array te klein.
Misschien is er een mogelijkheid dat de array bepaald wordt door de grootte van de tabel?
ar1 = sh1.Range("A2:.........?

 

[Andre175]

Alle problemen verholpen.
Deze vraag is voor mij opgelost.
Misschien dat er her en der wel iets anders/beter zou kunnen, maar voor mij werkt het iig.

Sub LijstKids()
    Application.ScreenUpdating = False
    With Sheets("Kids")
    
        s1 = .Range("Tbl_Kids").ListObject.ListRows.Count + 1
        s2 = .Range("Tbl_Kids").ListObject.ListColumns.Count + 1
        If s1 = 1 Then GoTo slaover
        .Range("A2:AV" & s1).ClearContents
        .ListObjects("Tbl_Kids").Resize Range("$A$1:$G$2")
slaover:
    End With
'   Exit Sub
    On Error Resume Next
    With Sheets("Kids")
       .Cells(1).Select
       .ListObjects.Add , , , 1, .Cells(1).CurrentRegion
    End With
    
    For Each it In Sheets
      If InStr("LadderKids", it.Name) = 0 Then
        With it.UsedRange
            Sheets("Kids").Cells(Rows.Count, 1).End(xlUp).Resize(.Rows.Count, .Columns.Count - 2) = .Offset(1, 2).Value
          End With
      End If
      Next
    
    Sheets("Kids").ListObjects("Tbl_Kids").DataBodyRange.RemoveDuplicates Array(1, 2, 5), xlYes
    
    
    Set sh1 = Sheets("Kids")
    Set sh2 = Sheets("Ladder")
    
    
    ar1 = sh1.Range("A2:O200")
    For i = 3 To Sheets.Count
        For j = 1 To sh1.Range("A" & Rows.Count).End(xlUp).Row - 1
            For jj = 1 To Sheets(i).Range("A" & Rows.Count).End(xlUp).Row - 1
                ar2 = Sheets(i).Range("A2:H50")
                If ar1(j, 1) = ar2(jj, 3) And ar1(j, 2) = ar2(jj, 4) And ar1(j, 5) = ar2(jj, 7) Then
'                    sh1.Cells(j + 1, i + 5).Value = Sheets("Ladder").Range("A" & i - 1)
                    sh1.Cells(j + 1, Columns.Count).End(xlToLeft).Offset(, 1) = Sheets("Ladder").Range("A" & i - 1)
                End If
            Next jj
        Next j
    Next i

    Sheets("Kids").ListObjects("Tbl_Kids").Resize Range("$A$1:o" & j)
    Application.ScreenUpdating = True
End Sub

iedereen bedankt voor het meedenken.