ik pik nu pas in, dus ik begrijp niet dat dit al zoveel reacties nodig heeft.
Blijkbaar ben je niet duidelijk of eerlijk genoeg naar de collega's, bon.
Ik begrijp niet dat je je gegevens zo neerzet, ik kijk naar je megafile van zoveel reacties geleden.
Dan vermoed ik dat je in tabblad "test" staat en dat je dan op een ander blad wilt gaan vert. zoeken.
Dat wordt een huzarenstukje.
Dus kan je maar beter dat tabblad "test" herwerken tot een nette tabel, waar, voor 1 record, alles naast elkaar staat en daarop dan een vert.zoeken loslaat.
Deze macro duurt wel eventjes, denk richting een uur, maar zet alles van Test om naar blad1. De vooruitgang kan je volgen op de statusbalk.
Maar als ik kijk naar de andere tabbladen, dan is dat mogelijks al in de omgekeerde richting gebeurd
Sub AndereLayout()
Dim arr(14) 'array die straks de uit te lezen rijen bepaalt
Const iMax = 1000 'om de zoveel records de dictionary dumpen
Set dict = CreateObject("scripting.dictionary") 'aanmaak dictionary
Sheets("blad1").UsedRange.Offset(1).ClearContents 'blad leegmaken
With Sheets("test")
Set c = Intersect(.Columns("B:F"), .UsedRange) 'bepalen uit te lezen gebied
End With
a = c.Value 'gegevens inlezen in array
For i = 1 To UBound(a) 'alles aflopen
If a(i, 1) = "B20" Then 'begin nieuwe reeks
Application.StatusBar = Space(10) & i & " van " & UBound(a) 'zo kan je op de statuslijn meevolgen waar je zit
For j = 0 To UBound(arr) 'bepalen welke rijen uitgelezen moeten worden
arr(j) = Application.Max(i, i + j - 1)
Next
If i + UBound(arr) - 1 <= UBound(a) Then
b = Application.Index(a, arr, 2) 'uitlezen D-kolom
b(1) = a(i, 5) 'overeenkomstige lijn in F-kolom
dict.Add dict.Count, b 'toevoegen aan dictionary
End If
If dict.Count >= iMax Then GoSub sub1 'tussentijds dumpen
End If
Next
sub1:
If dict.Count > 0 Then Sheets("blad1").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(dict.Count, UBound(arr) + 1).Value = Application.Index(dict.items, 0, 0) 'dictionary >> werkblad
If dict.Count >= iMax Then 'was je een tussentijdse dump bezig
dict.RemoveAll 'dictionary leegmaken
'If i > 100 Then Exit Sub 'stoppen tijdens testen
Return 'terugkeren naar loop
End If
Application.StatusBar = "" 'statusbar leegmaken
End Sub
