controle Tab die unieke record ID's controleert

[hoss312]

Hallo allemaal,

Ik hoop dat iemand mij kan helpen.

Ik moet veel data verwerken. Ik wil graag een controle Tab die alle unieke record ID's controleert die daadwerkelijk over de tabbladen verwerkt zijn.
Dus een controle van het aantal records voor bewerking versus het aantal records na bewerking, in een file. Zie voorbeeld file :thumb:

Alvast veel dank!

 

[AlexCEL]

Voldoet de optie in bijlage?

 

[hoss312]

AlexCEL,

Bedankt voor je bericht. Ik hoopte op een macro of script dat de gehele controle Tab maakt uit de 5 tabbladen die ik heb.

Ik weet niet eens of dat mogelijk is.

Mvg jos

 

[JEC.]

Kijk maar of deze werkt op een Mac.

Sub jec()
 Dim ws, dict, ar, a, sh, i As Long
 ReDim sq(100)
 
 Set ws = Sheets("Controle")
 Set dict = CreateObject("scripting.dictionary")
 
 With CreateObject("scripting.dictionary")
    For Each sh In Sheets(Array(1, 2, 3, 4, 5))
       ar = sh.Cells(1).CurrentRegion
       For i = 2 To UBound(ar)
          a = .Item(sh.Name)
          If IsEmpty(a) Then a = sq
          a(0) = sh.Name
          a(100) = a(100) + 1
          a(a(100)) = ar(i, 1)
          If sh.Index > 1 Then dict(ar(i, 1)) = ar(i, 1)
         .Item(sh.Name) = a
       Next
    Next
   ws.UsedRange.Clear
   ws.Range("A2").Resize(100, .Count) = Application.Transpose(.items)
   ws.Range("F3").Resize(dict.Count) = Application.Transpose(dict.keys)
 End With
End Sub

 

[JEC.]

Iets andere variant, zelfde output

Sub jec()
 Dim ws, sp, ar, a, sh, i As Long
 ReDim sq(100)
 
 Set ws = Sheets("Controle")
 With CreateObject("scripting.dictionary")
    For Each sh In Sheets(Array(1, 2, 3, 4, 5))
       ar = sh.Cells(1).CurrentRegion
       For i = 2 To UBound(ar)
          a = .Item(sh.Name)
          If IsEmpty(a) Then a = sq
          a(0) = sh.Name
          a(100) = a(100) + 1
          a(a(100)) = ar(i, 1)
          If sh.Index > 1 Then sp = sp & "|" & ar(i, 1)
         .Item(sh.Name) = a
       Next
    Next
   ws.UsedRange.Clear
   ws.Range("A2").Resize(100, .Count) = Application.Transpose(.items)
   ws.Range("F3").Resize(UBound(Split(sp, "|"))) = Application.Transpose(Split(Mid(sp, 2), "|"))
 End With
End Sub

 

[hoss312]

Jec,

Hartelijk dank voor de je bericht. Je eerste werkt helaas niet op een MAC vanwege ActiveX. Zou je een voorbeeld file kunnen maken van je tweede voorstel?

MVG Jos

 

[JEC.]

Hi Jos,

Probeer deze eens

Sub jec()
 Dim ar, xp, x As Long, j As Long, jj As Long
 ReDim sq(100, 5)
 xp = Array(1, 2, 3, 4, 5)
 sq(0, 5) = "Controle"
 
 For j = 0 To UBound(xp)
    ar = Sheets(xp(j)).Cells(1).CurrentRegion
    sq(0, j) = Sheets(xp(j)).Name
    For jj = 2 To UBound(ar)
       sq(jj - 1, j) = ar(jj, 1)
       If j > 0 Then sq(x + 1, 5) = ar(jj, 1): x = x + 1
    Next
 Next
 
 With Sheets("Controle")
   .UsedRange.Clear
   .Range("A2").Resize(UBound(sq) + 1, UBound(sq, 2) + 1) = sq
 End With
End Sub

 

[hoss312]

Jec,

Wederom enorm bedankt. Fantastisch! Ik denk dat we er bijna zijn. Als ik nog een tab toevoeg (dus ik maak een extra filter aan uit de bron gegevens en zet die als tab in mijn file, in mijn voorbeeld verwerkte records E) moet je macro aangepast worden.

Ik krijg dat niet voor elkaar. Kan je de macro zo maken dat dit ook automatisch wordt gedaan of kun je mij vertellen welke parameters ik moet aanpassen in je macro?

Om straks je niet nog een keer lastig te moeten vallen, heb ik mijn echte sheet zonder data ingevoegd.
1e Tab is een exportfile met in kolom A de unieke ID's,
2e Tab is een filter export met kopieen van Tab A met daarin ook kolom A met de unieke Id's,
3e Tab is een filter export met kopieen van Tab A met daarin ook kolom A met de unieke Id's,
4e Tab is een filter export met kopieen van Tab A met daarin ook kolom A met de unieke Id's,
5e Tab is een filter export met kopieen van Tab A met daarin ook kolom A met de unieke Id's,
6e Tab is een filter export met kopieen van Tab A met daarin ook kolom A met de unieke Id's,
7e Tab met de unieke Id's in kolom A is de controle Tab met jou macro,
Tab 8, 9 en 10 zijn gegevens die ik moet verwerken en gebruik voor de filters.
Tab 11 is de reset Tab om mijn macro om het gehele sheet te legen voor de volgende maand (ik doe dit maandelijks)

Alvast bedankt voor je hulp.

Ik zie dat we tegelijkertijd bezig zijn geweest en onze berichten elkaar gekruist hebben. Ik krijg echter mij voorbeeldfile niet meer geupload. Is dat omdat er een macro inzit?

MVG Jos

 

[JEC.]

Nu is hij dynamisch. Zolang je de sheets op volgorde houdt gaat het goed (A, B, C....op het eind de controle sheet)

Sub jec()
 Dim ar, xp, x As Long, j As Long, jj As Long
 xp = Evaluate("row(1:" & Sheets.Count - 1 & ")")
 ReDim sq(100, UBound(xp))
 sq(0, UBound(xp)) = "Controle"
 
 For j = 1 To UBound(xp)
    ar = Sheets(xp(j, 1)).Cells(1).CurrentRegion
    sq(0, j - 1) = Sheets(xp(j, 1)).Name
    For jj = 2 To UBound(ar)
       sq(jj - 1, j - 1) = ar(jj, 1)
       If j > 1 Then sq(x + 1, UBound(xp)) = ar(jj, 1): x = x + 1
    Next
 Next
 
 With Sheets("Controle")
   .UsedRange.Clear
   .Range("A2").Resize(UBound(sq) + 1, UBound(sq, 2) + 1) = sq
 End With
End Sub

 

[hoss312]

Beste Jec

ik krijg mijn daadwerkelijk excel sheet (met fake data) niet geupload voor verduidelijking. Ik denk dat ik het zelf werkend krijg als jij het script nog kan wijzigen dat hij alle tabbladen na de controletab niet meeneemt, dus alleen de tabladen voor de controletab. Die tabbladen erna gebruik ik namelijk om de data in het sheet goed te filteren.

Als ik mijn voorbeeldfile (voor de verduidelijking) ergens naar toe kan mailen hoor ik het graag .

MVG Jos

 

[Haije]

ik krijg mijn daadwerkelijk excel sheet (met fake data) niet geupload voor verduidelijking.

sla je file eens op als .xlsb, of zip hem en plaats de zip-file

 

[JEC.]

Probeer het eens door deze regel te gebruiken ipv de huidige

xp = Evaluate("row(1:" & Sheets("Controle").Index - 1 & ")")

 

[hoss312]

Hierbij alsnog mijn (fake data) origineel.

Bedankt voor jullie hulp.

 

[hoss312]

is er nog iemand die de oplossing in mijn nieuwe voorbeeld file kan zetten? Alvast bedankt voor de hulp.

 

[JEC.]

Een kwestie van de macro achter een module zetten

Sub jec()
 Dim ar, xp, x As Long, j As Long, jj As Long
 xp = Evaluate("row(1:" & Sheets("Controle").Index - 1 & ")")
 ReDim sq(100, UBound(xp))
 sq(0, UBound(xp)) = "Controle"
 
 For j = 1 To UBound(xp)
    ar = Sheets(xp(j, 1)).Cells(1).CurrentRegion
    sq(0, j - 1) = Sheets(xp(j, 1)).Name
    For jj = 2 To UBound(ar)
       sq(jj - 1, j - 1) = ar(jj, 1)
       If j > 1 Then sq(x + 1, UBound(xp)) = ar(jj, 1): x = x + 1
    Next
 Next
 
 With Sheets("Controle")
   .UsedRange.Clear
   .Range("A1").Resize(UBound(sq) + 1, UBound(sq, 2) + 1) = sq
 End With
End Sub

 

[hoss312]

Bedankt JEC, het is gelukt!