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

• #30877 Delila_1 veterán Carasc0 #30874

  Új Válasz 2016-03-06 15:44:34 #30877

  Ú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 #30874 üzenetére

  Tartományhoz (pl. C1:C25) használd a Konvertálatlan gombot.

  Sub Kever()
  Dim sor As Integer, sor1 As Integer
  
  Application.ScreenUpdating = False
  
  With Sheets("BÓNUSZ GENERÁTOROK")
  .Range("C1:C50").ClearContents
  .Range("A1:A50").Copy Range("C1")
  Randomize
  .Range("B1:B50") = "=RAND()"
  .Range("B1:B50").Copy
  .Range("B1").PasteSpecial xlPasteValues
  
  .Sort.SortFields.Clear
  .Sort.SortFields.Add Key:= _
  .Range("B1:B50"), SortOn:=xlSortOnValues, _
  Order:=xlAscending, DataOption:=xlSortNormal
  With .Sort
  .SetRange Range("B1:C50")
  .Header = xlGuess
  .Orientation = xlTopToBottom
  .Apply
  End With
  
  For sor = 1 To 20
  If Cells(sor, "C") = "" Then
  sor1 = Cells(sor, "C").End(xlDown).Row
  Cells(sor1, "C").Copy Cells(sor, "C")
  Cells(sor1, "C") = ""
  End If
  Next
  
  sor1 = Cells(sor, "C").End(xlDown).Row
  If Application.WorksheetFunction.CountA(Range("C23:C" & sor1 - 1)) = 0 Then _
  Range("C21:C" & sor1 - 1).Delete Shift:=xlUp
  sor1 = Cells(Rows.Count, "C").End(xlUp).Row
  
  For sor = sor1 To 21 Step -1
  Cells(sor, "C").Insert Shift:=xlDown
  Next
  
  sor1 = Cells(Rows.Count, "C").End(xlUp).Row
  If sor1 > 50 Then
  For sor = 50 To 45 Step -1
  If Cells(sor, "C") = "" Then
  Cells(sor, "C") = Cells(sor1, "C"): Cells(sor1, "C") = ""
  End If
  Next
  End If
  .Range("B1:B50").ClearContents
  .Cells(1).Select
  End With
  Application.ScreenUpdating = True
  End Sub

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