Új hozzászólás Aktív témák

• #27607 Delila_1 veterán Carasc0 #27604

  Új Válasz 2015-07-04 17:53:10 #27607

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz Carasc0 #27604 üzenetére

  Csak írd be az A oszlopba az adatokat. Ha nem kerek számot adna az adatok darabszámának a gyöke, hibajelzést kapsz.
  Hibátlan darabszámnál kiírja a "kevert" mátrixot a D1 cellától kezdődően. 9; 16; 25; és 36 adatra kipróbáltam, nem kell módosítanod semmit. Illetve ha nem tetszik, hogy D1-be kezd írni, akkor a
  sor = 1: oszlop = 4 sorban a 4-et írd át a kedvenc oszlopod sorszámára.

  Sub Kever()
  Dim usor As Integer, gyok As Integer, CV As Range
  Dim sor As Integer, oszlop As Integer
  
  Application.ScreenUpdating = False
  
  usor = Range("A" & Rows.Count).End(xlUp).Row
  
  On Error GoTo Vege
  gyok = Application.WorksheetFunction.ImSqrt(usor)
  
  Range("A1:A" & usor).Copy Range("B1")
  Range("C1:C" & usor) = "=rand()"
  Range("C1:C" & usor).Copy
  Range("C1").PasteSpecial xlPasteValues
  
  ActiveWorkbook.Worksheets("Munka1").Sort.SortFields.Clear
  ActiveWorkbook.Worksheets("Munka1").Sort.SortFields.Add Key:=Range("C1:C" & usor), _
  SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  With ActiveWorkbook.Worksheets("Munka1").Sort
  .SetRange Range("B1:C" & usor)
  .Header = xlGuess
  .MatchCase = False
  .Orientation = xlTopToBottom
  .SortMethod = xlPinYin
  .Apply
  End With
  
  sor = 1: oszlop = 4
  For Each CV In Range("B1:B" & usor)
  If sor > gyok Then
  sor = 1
  oszlop = oszlop + 1
  End If
  CV.Copy Cells(sor, oszlop)
  sor = sor + 1
  Next
  
  Range("B1:C" & usor).ClearContents
  Range("D1").Select
  Application.ScreenUpdating = True
  Exit Sub
  
  Vege:
  MsgBox "Nem adnak mátrixot az adatok", vbInformation
  Application.ScreenUpdating = True
  End Sub

Új hozzászólás Aktív témák