Gegevens blad 1 in één kolom onder elkaar op blad 2

[Viewable]

Hi,

Op blad 1 heb ik gegevens vanaf rij 2 t/m ... (kan variëren hoeveel rijen) en aantal kolommen kan ook variëren
Maar al deze gegevens, wat in totaal soms 200.000 cellen kunnen zijn, wil ik in 1 kolom onder elkaar op blad 2 vanaf cel A2. En het liefst in willekeurige volgorde.

Kan iemand mij helpen? Of wellicht doorverwijzen naar een antwoord op dit forum, heb ik zelf nml niet kunnen vinden.

Dank je wel.

 

[VenA]

Met een macro

Sub VenA()
  ar = Sheet1.Cells(1).CurrentRegion
  ReDim ar1(UBound(ar) * UBound(ar, 2))
  For j = 2 To UBound(ar)
    For jj = 1 To UBound(ar, 2)
      ar1(t) = ar(j, jj)
      t = t + 1
    Next jj
  Next j
  Sheet2.Cells(2, 1).Resize(t) = Application.Transpose(ar1)
End Sub

 

[Viewable]

Met een macro

Sub VenA()
  ar = Sheet1.Cells(1).CurrentRegion
  ReDim ar1(UBound(ar) * UBound(ar, 2))
  For j = 2 To UBound(ar)
    For jj = 1 To UBound(ar, 2)
      ar1(t) = ar(j, jj)
      t = t + 1
    Next jj
  Next j
  Sheet2.Cells(2, 1).Resize(t) = Application.Transpose(ar1)
End Sub

Top, dank je wel. Dat is deel 1.
Hoe zorg ik ervoor dat de codes in random volgorde in de kolom komen te staan?
Nu staan ze "horizontale" volgorde

 

[VenA]

Het quoten is niet nodig. Zet er een kolom achter met RAND() en sorteer daar op.

 

[Viewable]

"Hett quoten is niet nodig."
Bedoel je dat ik jouw code niet moet quoten in mijn antwoord? Andres snap ik deze niet.

"Zet er een kolom achter met RAND() en sorteer daar op."
Maar als ik 200.000 rijen heb, moet ik dan eerst bij alle rijen een RAND() nummer slepen, dan sorteren?
Kan ik dat op een makkelijkere manier doen?

 

[cow18]

leuke toevoeging, in willekeurige volgorde :thumb:

Sub BS()
   imax = 25000                                  'max ivm. transponeren
   Set List = CreateObject("System.Collections.ArrayList")   'aanmaak gesorteerde lijst
   Sheets("Sheet2").Range("A1").CurrentRegion.Offset(1).Resize(, 2).ClearContents   'uitvoer leegmaken

   ar = Sheets("Sheet1").Cells(1).CurrentRegion  'inlezen gegevens
   For j = 2 To UBound(ar)
      For jj = 1 To UBound(ar, 2)
         List.Add Format(Rnd(), "0.000000000000") & Chr(1) & "|" & ar(1, jj) & "\" & ar(j, jj)   'record toevoegen aan lijst
      Next jj
   Next j

   List.Sort                                     'lijst sorteren
   Do
      Set kl = List.Clone                        'lijst klonen
      b = kl.Count > imax                        'indien lijst nog te lang
      If b Then kl.Removerange imax, kl.Count - imax   'alleen de eerst zoveel records overhouden
      a = Filter(Split(Join(kl.toarray, "|"), "|"), Chr(1), 0, vbTextCompare)   'pak alleen het 2e deel van al die records
      Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(a) + 1).Value = Application.Transpose(a)   'toevoegen aan uitvoer
      If b Then List.Removerange 0, imax         'indien nog teveel records, dan de 1e zoveel records weggooien
   Loop While b                                  'loopje

   With Sheets("sheet2").Range("A1").CurrentRegion.Offset(1).Resize(, 1)   'toegevoegde records
      .TextToColumns .Range("a1"), xlDelimited, xlDoubleQuote, False, False, False, False, False, True, "\"   'tekst naar kolommen
   End With

End Sub

 

[Viewable]

@VenA

"Hett quoten is niet nodig."
Bedoel je dat ik jouw code niet moet quoten in mijn antwoord? Andres snap ik deze niet.

"Zet er een kolom achter met RAND() en sorteer daar op."
Maar als ik 200.000 rijen heb, moet ik dan eerst bij alle rijen een RAND() nummer slepen, dan sorteren?
Kan ik dat op een makkelijkere manier doen?

@cow18

Ik krijg een foutmelding. Zie bijlages

 

[cow18]

tiens, eigenaardig.
Wel, dan doen we het met een gewone dictionary

Sub BS()
   Set dict = CreateObject("scripting.dictionary")   'aanmaak dictionary
   Sheets("Sheet2").Range("A1").CurrentRegion.Offset(1).Resize(, 3).ClearContents   'uitvoer leegmaken

   ar = Sheets("Sheet1").Cells(1).CurrentRegion  'inlezen gegevens
   For j = 2 To UBound(ar)
      For jj = 1 To UBound(ar, 2)
         dict.Add dict.Count, Array(ar(1, jj), ar(j, jj), Format(Rnd(), "0.000000000000"))   'record toevoegen aan lijst
      Next jj
   Next j

   With Sheets("sheet2").Range("A2").Resize(dict.Count, 3)
      .Value = Application.Index(dict.items, 0, 0)
      .Sort .Range("C1"), xlAscending, Header:=False
   End With

End Sub

 

[Viewable]

@VenA

Ik heb jouw code geprobeerd met 155.000 codes op sheet1.
Tot en met rij 24.085 krijg ik codes en daarna allemaal #N/A t/m rij 155.001

@cow18

Wederom met de nieuwe code dezelfde melding. Kan het uitmaken dat ik Excel for Mac gebruik (Version 16.37 (20051002))?

 

[JEC.]

Dat kan wel uitmaken. VBA voor mac heeft niet alle functies die windows wel heeft

 

[cow18]

- een transpose loopt ergens tegen een limiet aan, ik dacht 65.000 en een beetje, maar had ooit in een topic daar ook problemen mee.
Dus doe ik dat nu in een loopje bijvoorbeeld per 25.000, zie #6, maar jij komt nu met 24.085 af, dus had ik toch nog net een beetje te hoog gemikt.

- in mijn geval gebruik ik "late binding", wat simplistisch gezegd, betekent dat je geen verwijzing nodig hebt.
Dus dan moet ik in de VBA-editor bij extra>verwijzingen niet de "Microsoft Scripting Runtime" aanvinken.
Kijk daar anders toch eens om te zien of er daar niet een verwijzing staat met de melding "ONTBREEKT : ....", misschien is het in de Mac toch net een klein beetje anders.

Even gegoogled en dan vind ik dit https://github.com/VBA-tools/VBA-Dictionary
Ik kijk er anders vanavond nog eens naar, tenzij iemand anders zin heeft.

Wat me opviel

...and import Dictionary.cls into your VBA project...

, dus heb je toch ergens een verwijzing nodig ???

 

[Viewable]

Dank allen,

Via een ander kanaal heb ik dit gekregen en blijkt goed te werken.

Sub Willekeurige_Volgorde()
Application.DisplayAlerts = False
Application.ScreenUpdating = False

aantal_kolommen = 155 'Dit kun je aanpassen
aantal_rijen = 1000   'Dit kun je aanpassen

For rij = 2 To aantal_rijen + 1

For kolom = 1 To aantal_kolommen

Sheets("Sheet2").Cells(((aantal_rijen * (kolom - 1) + rij)), 1) = Sheets("Sheet1").Cells(rij, kolom)
Sheets("Sheet2").Cells(((aantal_rijen * (kolom - 1) + rij)), 2) = Rnd()

Next kolom

Application.StatusBar = rij

Next rij

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

 

[cow18]

en nu nog sorteren ... .

Het schrijven naar je werkblad kost tijd !
Je macro met 155.000 schrijfopdrachten kost op mijn PC 19,2 sec, mijn macro met 1 schrijfopdracht 2.6 sec. (factor 9)

Als alles maar een éénmalige opgave is, dan is deze opmerking te verwaarlozen.

 

[Viewable]

en nu nog sorteren ... .

Het schrijven naar je werkblad kost tijd !
Je macro met 155.000 schrijfopdrachten kost op mijn PC 19,2 sec, mijn macro met 1 schrijfopdracht 2.6 sec. (factor 9)

Als alles maar een éénmalige opgave is, dan is deze opmerking te verwaarlozen.

Klopt... maar ik krijg jouw oplossing niet werkend. Anders is de tijdwinst een goede bijkomstigheid. En het maakt dan niet uit hoeveel rijen en kolommen ik vul met codes.
Al met al zal dit ongeveer 10 tot 20 keer per jaar voorkomen.

Is nog mee te leven... toch?

 

[cow18]

10 à 20 keer per jaar 20 sec, een kop koffie duurt langer.
Suc6 er mee :thumb:

 

[cow18]

toch nog een pogingetje, for the joke.
natte vinger 230.000 records in 5.5 sec in willekeurige volgorde

 

[VenA]

± 1 seconde

Sub VenA()
  t = Timer
  ar = Sheets("Sheet1").Cells(1).CurrentRegion
  ReDim ar1(UBound(ar) * UBound(ar, 2), 1)
  For j = 2 To UBound(ar)
    For jj = 1 To UBound(ar, 2)
      If ar(j, jj) <> "" Then
        ar1(x, 0) = ar(j, jj)
        ar1(x, 1) = Rnd
        x = x + 1
      End If
    Next jj
  Next j
  
  With Sheets("Sheet2").Cells(1)
    .CurrentRegion.Offset(1).ClearContents
    .Cells(2, 1).Resize(x, 2) = ar1
    .CurrentRegion.Sort .Cells(1, 2), , , , , , , xlYes
    .CurrentRegion.Offset(1).Columns(2).ClearContents
  End With
  MsgBox "Daar was ik nu eventjes " & Timer - t & " sec mee bezig"
End Sub

 

[cow18]

hoedje af