Script om data uit meerdere tabbladen te kopieren

Status
Niet open voor verdere reacties.
globe

globe

Verenigingslid
Lid geworden
18 mrt 2001
Berichten
3.584
Ik heb een Excel lijst waar meerdere tabbladen in zitten, dit varieert van 5 tot 40.

Nu gebruik ik onderstaande code om deze allemaal (behalve de eerste) te kopieren naar een tabblad genaamd order1.
Dit tabblad gebruik ik dan vervolgens weer om een complete sheet met alle data te hebben zodat ik de rest weg kan gooien.
Ik ben fan van alle data in 1 sheet.

het probleem is dat niet alle sheets hetzelfde opgebouwd zijn, de eerste 5 kolommen kunnen varieren, kolom F is echter altijd hetzelfde.
Dus wanneer "F" een waarde bevat moet de regel uit de sheet naar de sheet Order1 gekopieerd worden.

In het voorbeeld zijn bv bij de tab MANNEN niet alle artikelnummers in Kolom A gevuld.


Onderstaand script kijkt echter naar de eerste kolom. Als daar een waarde staat wordt de regel wel gekopieerd, staat daar niks wordt de regel niet gekopieerd.

Hoe kan ik de code aanpassen zodat er naar kolom 6 "F" wordt gekeken?

Oh ja... er staan ook lege regels tussen de data. Deze hoeven eigenlijk meegenomen te worden. Onderstaand script doet dat niet.

Code: 
aantaltabs = Application.Sheets.Count

Dim j, iWS As Integer
   For iWS = 2 To aantaltabs
     For j = 1 To Sheets(iWS).Cells(Rows.Count, 1).End(xlUp).Row
        Worksheets("order1").Range("A65536").End(xlUp).Offset(1).EntireRow.Value _
= Worksheets(iWS).Cells(j, 1).EntireRow.Value
     Next j
   Next iWS

En wat eigenlijk nog een vele mooiere oplossing zou zijn is dat alleen kolommen F, O, P en Q worden gekopieerd naar de sheet Order1 ;)

Mijn dank is groot!
 

Bijlagen

  • helpmijVB.xlsx
    22,2 KB · Weergaven: 13
Laatst bewerkt:
Wat valt er te kopiëren als in kolom P en Q niets staat ?

Code: 
Sub M_snb()
  For Each it In Array(Blad2, Blad3)
    sn = it.Cells(1).CurrentRegion.Offset(2).Resize(, 17)
    Blad6.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(sn), 4) = Application.Index(sn, Evaluate("row(1:" & UBound(sn) & ")"), Array(6, 15, 16, 17))
  Next
End Sub
 
Laatst bewerkt:
Als je sheet 40 tabbladen kan bevatten en als er tussendoor ook nog lege regels zitten in kolom F.

Code: 
Sub jec()
  Dim ar, sh As Variant, i As Long
  With CreateObject("scripting.dictionary")
    For Each sh In ThisWorkbook.Sheets
      If sh.Index > 1 Then
        ar = sh.Cells(1, 1).CurrentRegion.Resize(, 17)
        For i = 2 To UBound(ar)
          If Len(ar(i, 6)) Then .Item(.Count) = Array(ar(i, 6), ar(i, 15), ar(i, 16), ar(i, 17))
        Next
      End If
    Next
   Sheets("Order1").Cells(1, 1).Resize(.Count, 4) = Application.Index(.items, 0, 0)
 End With
End Sub
 
JVeer zei:
Als je sheet 40 tabbladen kan bevatten en als er tussendoor ook nog lege regels zitten in kolom F.

Code: 
Sub jec()
  Dim ar, sh As Variant, i As Long
  With CreateObject("scripting.dictionary")
    For Each sh In ThisWorkbook.Sheets
      If sh.Index > 1 Then
        ar = sh.Cells(1, 1).CurrentRegion.Resize(, 17)
        For i = 2 To UBound(ar)
          If Len(ar(i, 6)) Then .Item(.Count) = Array(ar(i, 6), ar(i, 15), ar(i, 16), ar(i, 17))
        Next
      End If
    Next
   Sheets("Order1").Cells(1, 1).Resize(.Count, 4) = Application.Index(.items, 0, 0)
 End With
End Sub
Klik om te vergroten...


Ik krijg op
Code: 
 Sheets("Order1").Cells(1, 1).Resize(.Count, 4) = Application.Index(.items, 0, 0)
een fout 13 tijdens uitvoering, types komen niet overeen
 
snb zei:
Wat valt er te kopiëren als in kolom P en Q niets staat ?

Code: 
Sub M_snb()
  For Each it In Array(Blad2, Blad3)
    sn = it.Cells(1).CurrentRegion.Offset(2).Resize(, 17)
    Blad6.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(sn), 4) = Application.Index(sn, Evaluate("row(1:" & UBound(sn) & ")"), Array(6, 15, 16, 17))
  Next
End Sub
Klik om te vergroten...

SNB, bedankt voor je vlotte reactie

In het voorbeeld staat idd hier geen data zie ik nu, in sommige tabs van het origineel wel. Dit kan verschillen.

Jouw code werkt prima maar is niet geschikt wanneer het aantal tabs varieert denk ik?
 
Klopt je tabbladnaam? Bij mij loopt hij prima
 
JVeer zei:
Klopt je tabbladnaam? Bij mij loopt hij prima
Klik om te vergroten...

yep, "Order1", in mijn voorbeeld file krijg ik de foutmelding en ook op de originele file helaas.

Office365 of maakt dat niks uit?
 
Dus ook in dit bestand als je op de knop drukt op tabblad Order1?
 

Bijlagen

  • helpmijVB.xlsm
    30,1 KB · Weergaven: 16
Aha, ik zie waar het mis gaat.

De macro in jouw file uitvoeren werkt prima.
Laat ik echter de macro vanuit mijn originele files draaien kopieert deze de data uit de excel waar de VBA module in zit.

Dat is niet de bedoeling.

in de definitieve VBA komt er trouwens een stukje script voor om het tabblad "Order1" toe te voegen, dat werkt prima trouwens.

Ik heb nu de code in dit veranderd, hierdoor wordt het juiste workbook actief gezet:

Het probleem is nu dat er bij lege regels gestopt wordt, er wordt dus niet de gehele sheet naar tab "order1" gekopieerd.

Code: 
Sub jec()

Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Order1"
    Sheets("Order1").Select
    Cells.Select
    Selection.NumberFormat = "@"
    
    Dim wbkCurrent As Workbook

    Set wbkCurrent = ActiveWorkbook
         
  Dim ar, sh As Variant, i As Long
  With CreateObject("scripting.dictionary")
    For Each sh In wbkCurrent.Sheets
      If sh.Index > 1 Then
        ar = sh.Cells(1, 1).CurrentRegion.Resize(, 17)
        For i = 2 To UBound(ar)
          If Len(ar(i, 6)) Then .Item(.Count) = Array(ar(i, 6), ar(i, 15), ar(i, 16), ar(i, 17))
        Next
      End If
    Next
   Sheets("Order1").Cells(1, 1).Resize(.Count, 4) = Application.Index(.items, 0, 0)
 End With
End Sub
 
Laatst bewerkt:
Zo dan

Code: 
Sub jec()
 Dim ar, sh As Variant, i As Long, dict As Object
 
 Set dict = CreateObject("scripting.dictionary")
 For Each sh In ThisWorkbook.Sheets
    If sh.Index > 1 Then
      ar = sh.Cells(1, 1).CurrentRegion.Resize(, 17)
      For i = 2 To UBound(ar)
          If Len(ar(i, 6)) Then dict(dict.Count) = Array(ar(i, 6), ar(i, 15), ar(i, 16), ar(i, 17))
      Next
    End If
 Next
 With Sheets.Add(, Sheets(Sheets.Count))
    .Name = "Order1"
    .Cells.NumberFormat = "@"
    .Cells(1, 1).Resize(dict.Count, 4) = Application.Index(dict.items, 0, 0)
 End With
End Sub
 
Laatst bewerkt:
Code: 
Sub jec()

Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Order1"
    Sheets("Order1").Select
    Cells.Select
    Selection.NumberFormat = "@"
    
    Dim wbkCurrent As Workbook

    Set wbkCurrent = ActiveWorkbook
         
  Dim ar, sh As Variant, i As Long
  With CreateObject("scripting.dictionary")
    For Each sh In wbkCurrent.Sheets
      If sh.Index > 1 Then
        ar = sh.Cells(1, 1).CurrentRegion.Resize(, 17)
        For i = 2 To UBound(ar)
          If Len(ar(i, 6)) Then .Item(.Count) = Array(ar(i, 6), ar(i, 15), ar(i, 16), ar(i, 17))
        Next
      End If
    Next
   Sheets("Order1").Cells(1, 1).Resize(.Count, 4) = Application.Index(.items, 0, 0)
 End With
End Sub

Nope, ook nu wordt de data uit de file waar de macro in zit gekopieerd. Mijn script hierboven (jouw aangepaste script) lijkt het goed te doen maar stopt met kopieren wanneer er een lege regel tussen zit, Dus niet alleen een leeg veld in kolom F maar een hele lege regel. Niet alle data wordt dus gekopieerd.
 
Laatst bewerkt:
Dan staat de macro in een verkeerd bestand, of je moet de macro herschrijven. Het deel van het kopieren lijkt me sterk. Als F niet leeg is zou hij de 4 gewenste kolommen moeten meenemen
 
Jveer,

Dank voor het meedenken en je mooie script.

Ik heb de macro al zo aangepast dat deze de actieve sheet gebruikt, dat gaat lekker.
Maar hij loopt echt stuk op lege regels, bij de eerste lege regel stopt het kopiëren.

Check bijgaand voorbeeld van je eigen file.
Ik heb hier 2 lege regels ingezet, nu wordt niet alle data gekopieerd.

Hoe krijg ik het voor elkaar om alle regels waar in F een waarde staat te kopiëren?
 

Bijlagen

  • Kopie van helpmijVB-2.xlsm
    31,3 KB · Weergaven: 11
Code: 
Sub M_snb()
  For Each it In sheets
    sn = it.Cells(1).CurrentRegion.Offset(2).Resize(, 17)
    if it. index >1 then Blad6.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(sn), 4) = Application.Index(sn, Evaluate("row(1:" & UBound(sn) & ")"), Array(6, 15, 16, 17))
  Next
End Sub
 
Oke het kwam door het onderbreken van de currentregion.
Dit zou moeten werken, losgezien van waar je hem runt uiteraard.

Code: 
Sub jec()
 Dim ar, sh As Variant, i As Long, dict As Object
 
 Set dict = CreateObject("scripting.dictionary")
 For Each sh In ThisWorkbook.Sheets
    If sh.Index > 1 Then
      ar = sh.Range("A1:Q" & sh.Range("F" & Rows.Count).End(xlUp).Row)
      For i = 2 To UBound(ar)
          If Len(ar(i, 6)) Then dict(dict.Count) = Array(ar(i, 6), ar(i, 15), ar(i, 16), ar(i, 17))
      Next
    End If
 Next
 With Sheets.Add(, Sheets(Sheets.Count))
    .Name = "Order1"
    .Cells.NumberFormat = "@"
    .Cells(1, 1).Resize(dict.Count, 4) = Application.Index(dict.items, 0, 0)
 End With
End Sub
 
top JV!

Dit doet exact wat ik wil. En vele malen sneller dan mijn originele script.

SNB, ook bedankt voor het meedenken
 
Mooizo!:thumb:Succes
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan