VBA om data van andere tabbladen samen te voegen

[ropo64]

hallo,
ik gebruik onderstaande vba code om van alle tabbladen de unieke namen naar 1 tabblad (punten 2003) te halen.
kan deze code aangepast worden zodat een specifiek tabblad overgeslagen word?

alvast bedankt!

Sub Artikelnummers()
Dim a, ws As Worksheet, dict As Object, j As Long
Set dict = CreateObject("Scripting.Dictionary")
For Each ws In ThisWorkbook.Worksheets
  If Left(ws.Name, 6) <> "punten" Then
    a = ws.Range("d2:e" & ws.Cells(Rows.Count, 2).End(xlUp).Row)
      For j = 1 To UBound(a)
         dict.Item(a(j, 1)) = a(j, 2)
      Next j
  End If
Next ws
Worksheets("punten 2003").Range("A2").Resize(UBound(dict.Keys) + 1, 2) = Application.Transpose(Array(dict.Keys, dict.Items))
End Sub

 

[HSV]

Zou dit werken?

For Each ws In ThisWorkbook.Worksheets

If Left(ws.Name, 6) <> "punten" [COLOR=#0000ff]and lcase(ws.name) <> "naamvanbladwatnietmeemoetdoen"[/COLOR] Then

 

[ropo64]

hoi Harry,
dit werkt goed.
nog 1 vraagje,
hoe verleng ik deze code om meer tabbladen over te slaan?

alvast bedankt!

 

[ropo64]

ik heb dezelfde code (in het blauw) daar weer achter geplakt en nu
heb ik een volgend tabblad over geslagen.
bedankt in ieder geval!

het werkt perfect!

Groet Robert

 

[ropo64]

hallo,
ik heb nog een vraagje over deze code:
ik wil graag 9 opvolgende rijen tonen in plaats van 2
wat moet er veranderd worden aan deze code?

 

[HSV]

Doe het eens zo.

Resize([COLOR=#0000ff]dict.count[/COLOR], 2)

Anders een bestand plaatsen ontdaan van gevoelige info.

 

[ropo64]

het uploaden werkt niet of ik doe iets fout...

 

[HSV]

Sla het bestand op als .xlsb dan is het wat kleiner.

 

[ropo64]

VBA om data van andere tabbladen samen te voegen (2)

hoi,
even opnieuw denk ik maar.
ik wil dat er 7 rijen ipv 2 rijen worden overgenomen naar het overzichtblad (Week 48)
tevens komen er totaal 50 tabbladen bij die allemaal een jaarnummer hebben bv 2018, 2017, 2016
als het nodig is wil ik met een toegevoegde code bebaalde tabbladen "uit kunnen zetten" tijdelijk wel te verstaan.

alvast bedankt voor je hulp!

groet robert

 

[HSV]

Zo bedoel je?

Sub Artikelnummers()
Dim sv, a, b(6), ws As Worksheet, dict As Object, j As Long
Set dict = CreateObject("Scripting.Dictionary")
For Each ws In ThisWorkbook.Worksheets
  If Left(ws.Name, 4) <> "Week" Then
    sv = ws.Cells(1).CurrentRegion
      If IsArray(sv) Then
        For i = 2 To UBound(sv)
           a = dict.Item(sv(i, 2))
            If IsEmpty(a) Then a = b
               a(0) = sv(i, 2)
               a(1) = sv(i, 3)
               a(2) = sv(i, 6)
               a(3) = sv(i, 7)
               a(4) = sv(i, 8)
               a(5) = sv(i, 9)
               a(6) = sv(i, 10)
           dict.Item(sv(i, 2)) = a
          Next i
  End If
  End If
Next ws
Worksheets("Week 48").Range("A2").Resize(dict.Count, 7) = Application.Index(dict.items, 0, 0)
End Sub

Misschien is onderstaande ook al voldoende.

Sub Artikelnummers()
Dim sv, a, b(6), ws As Worksheet, dict As Object, j As Long
Set dict = CreateObject("Scripting.Dictionary")
For Each ws In ThisWorkbook.Worksheets
  If Left(ws.Name, 4) <> "Week" Then
    sv = ws.Cells(1).CurrentRegion
        For i = 2 To UBound(sv)
          dict(sv(i, 2)) = Application.Index(sv, i, Array(2, 3, 6, 7, 8, 9, 10))
        Next i
  End If
 Next ws
Worksheets("Week 48").Range("A2").Resize(dict.Count, 7) = Application.Index(dict.items, 0, 0)
End Sub

 

[ropo64]

Harry,
ik heb de eerste code gebruikt, deze werkt goed met de 7 rijen.
bedankt daarvoor.
ik neem aan dat het onderste gedeelte van de eerste code is om sommige tabbladen niet mee te laten gaan maar dat snap ik nog niet helemaal...

groet robert

 

[HSV]

Je bedoelt 7 kolommen.

Een ding wat ik nog niet weet.
Zo te zien is elk blad identiek aan gegevens qua getallen per artikelnummer, of komen in de kolommen E t/m J ook andere getallen voor.

 

[ropo64]

dit was even een voorbeeld omdat het juiste bestand te groot is voor de website.
normaal gesproken is de eerste kolom een uniek nummer
en ja ik bedoel kolommen natuurlijk

maar hoe kan ik sommige tabbladen overslaan?
zit dit ook in de code verwerkt want ik zie het niet en heb er ook geen verstand van ;-)

groet robert

 

[HSV]

Nee, tabbladen overslaan zit er niet in verwerkt.

De tweede kolom is een uniek nummer, maar de gegevens van elk uniek nummer (kolom 6 t/m 10) kunnen verschillend zijn.
Moet je die gegevens dan ook niet hebben?

 

[ropo64]

het unieke nummer komt in kolom 1 de andere opvolgende 6 kolommen zijn extra data
ik kreeg wel een foutmelding in vba als er een cel leeg was in de toprij.

 

[HSV]

Dan verander je....

sv = ws.Cells(1).CurrentRegion

...in.

sv = ws.Cells(1).CurrentRegion.resize(,10)

 

[ropo64]

VBA om data van andere tabbladen samen te voegen (2)

hoi,
ik voeg even een aangepaste versie toe zodat je kan zien wat ik bedoel

 

[HSV]

Daarin kan ik niet zien wat je bedoelt.
Het is je oude macro die erin staat zonder extra gegevens zoals je het wilt hebben.

 

[ropo64]

oke, misschien leg ik het niet goed uit, sorry voor het ongemak.

van elk tabblad moeten het unieke nummer (vanuit kolom a, startend in a2) en alle vervolg kolommen die daar aan vast zitten naar het blad week 48.
eigenlijk een complete copie naar blad week 48 zonder de duplicaten

 

[ropo64]

eigenlijk is die op deze manier goed genoeg:
alleen zoek ik nog een oplossing om sommige bladen niet mee te laten lopen.
deze bladen zijn namelijk wel gevuld met data maar nog niet klaar zeg maar.

Sub Artikelnummers()
Dim sv, a, b(10), ws As Worksheet, dict As Object, j As Long
Set dict = CreateObject("Scripting.Dictionary")
For Each ws In ThisWorkbook.Worksheets
  If Left(ws.Name, 4) <> "Week" Then
    sv = ws.Cells(1).CurrentRegion.Resize(, 10)
      If IsArray(sv) Then
        For i = 2 To UBound(sv)
           a = dict.Item(sv(i, 2))
            If IsEmpty(a) Then a = b
               a(0) = sv(i, 1)
               a(1) = sv(i, 2)
               a(2) = sv(i, 3)
               a(3) = sv(i, 4)
               a(4) = sv(i, 5)
               a(5) = sv(i, 6)
               a(6) = sv(i, 7)
               a(7) = sv(i, 8)
               a(8) = sv(i, 9)
           dict.Item(sv(i, 2)) = a
          Next i
  End If
  End If
Next ws
Worksheets("Week 48").Range("A2").Resize(dict.Count, 10) = Application.Index(dict.items, 0, 0)
End Sub