Excel VBA - kopírování dat do sloupců Vyřešeno

[msabrsula]

Ahoj všem,

potřeboval bych poradit s jedním makrem v Excelu. V příloze je vložen ukázkový soubor.

Jde o to, že do sloupce C vkládám určitá data (buňky C2:C100000) a ty je potřeba náhodně seřadit a tyto náhodně seřazené data zkopírovat do sloupce F (F2:F100000). Dále data ze sloupce C znova náhodně seřadit a vložit do sloupce G (G2:G100000). Dále data ze sloupce C znova náhodně seřadit a vložit do sloupce H (H2:H100000). A tak pořád dále. Potřebuji dostat 3000 sloupců (F:DKO) kde budou náhodně seřazená data ze sloupce C.

Podařilo se mi udělat makro, které provede první operaci – tj.: náhodně seřadí data ze sloupce C a ty zkopíruje do sloupce F. Teď ale nevím jak dál – jak dostat pokaždé znova seřazená dat do dalších 2999 sloupců.

Děkuji za pomoc a doufám, že jsem to napsal srozumitelně.

Moje vytvořené makro:

Sub Nahodne_poradi_dat()
'
' Nahodne_poradi_dat Makro
'
'
Range("C:D").Select
ActiveWorkbook.Worksheets("List1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("List1").Sort.SortFields.Add Key:=Range("D2:D100000"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("List1").Sort
.SetRange Range("C1:D100000")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("C2:C100000").Select
Selection.Copy
Range("F2").Select
ActiveSheet.Paste

End Sub

[Reklama]

[guest]

Náhodná čísla používáte, takže OK. Pak může nastoupit buď filtr a řazení nebo maticový vzorec. Sto tisíc dat je ale maticový vzorec masakr, takže doporučuju stávající postup, ovládání filtru přes VBA a kopírování na jiný list a do patřičného sloupce s využitím .Offset.

[lubo.]

Zkus něco takového:

Kód: Vybrat vše

Sub Nahodne_poradi_dat2()
Dim V() As Variant
Dim N1 As Long, N2 As Long
Dim X As Long
Dim i As Long
Dim ss As Variant

Dim cil As Range

  V = Range("C2:C101").Value2        ' rozsah zdrojových dat
  N1 = LBound(V, 1)
  N2 = UBound(V, 1)
 
  Set cil = Range("F2").Resize(N2, 1)
 
  For s = 1 To 10   ' nastav počet sloupců
    For i = N2 To N1 + 1 Step -1
       X = Int(Rnd() * (i - N1 + 1)) + N1
       ss = V(X, 1)
       V(X, 1) = V(i, 1)
       V(i, 1) = ss
    Next i
     
    cil.Value2 = V
    Set cil = cil.Offset(0, 1)
 
  Next ' sloupec
End Sub



[guest]

No, něco jsem si zkusil...

http://leteckaposta.cz/419941086

Bohužel to kolabuje cca na 1300 sloupcích. Nemám pravděpodobně dost prostředků na tuhle megalomanskou úlohu (100 000 řádků x 3 000 sloupců). I když ta data vygenerujete, v Excelu je bez pořádné výbavy nikdy nezpracujete.

[msabrsula]

Ahojte, oběma moc děkuju za reakci a za pomoc

To xlnc:
Moc děkuju za soubor s makrem-dělá to přesně co potřebuju Můj počítač také neudržel 100000 řádků, ale po redukci na 50000 (což pro většinu případů bude stačit je to OK.

Mám ještě jeden dotaz. Seřazené hodnoty se kopírují do Listu2 od buňky A1. V Listu 2 bych na začátku potřeboval jeden prázdný sloupec a řádek - tzn. aby se data nakopírovaly až od buňky B2. Můžete mi pomoci jak upravit makro, aby to takto fungovalo?

Zkoušel jsem upravit Cil v makru takto: " Set wshListCil = Worksheets("List2!B2") " , ale to nefunguje.

Díky za pomoc


Makro:

Kód: Vybrat vše

Sub Makro1()

    Dim wshListZdroj As Worksheet
    Dim wshListCil As Worksheet

    Dim rngOblastDat As Range

    Dim i As Integer

    Application.ScreenUpdating = False

    'wshListZdroj má nastaven ruční přepočet
    Set wshListZdroj = Worksheets("List1")
    Set wshListCil = Worksheets("List2")

    'oblast dat pro kopírování
    Set rngOblastDat = wshListZdroj.Range("B1:B50000")

    For i = 1 To 3000

        Application.StatusBar = "Zpracovávám " & i & " záznam."
       
        'přepočet listu
        wshListZdroj.Calculate

        'a setřídění
        With wshListZdroj.Sort
            .SetRange Range("A1:B50000")
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

        'kopie dat do cílového listu
        wshListCil.Cells(1, i).Resize(50000, 1).Value = rngOblastDat.Value
    Next i
   
    Application.StatusBar = False
    Application.ScreenUpdating = True

End Sub



[guest]

Kód: Vybrat vše

        'kopie dat do cílového listu
        wshListCil.Cells(2, i + 1).Resize(50000, 1).Value = rngOblastDat.Value

[msabrsula]

To xlnc:
Super práce, moc děkuju :)