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

• #13351 Delila_1 veterán jaszy83 #13345

  Új Válasz 2012-03-30 13:11:45 #13351

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

  Gyorsabb futást eredményez az újabb makró, és csak a két lap nevét kell módosítani, meg esetleg az 5000 sort.

  Sub Rendez()
  Dim sor As Long, usor As Long, oszlop As Integer
  Dim WS As Worksheet, WSF As Worksheet
  Application.ScreenUpdating = False
  
  Set WS = Sheets("Munka3") '***************
  Set WSF = Sheets("Felvitel") '***************
  usor = WSF.Range("A" & Rows.Count).End(xlUp).Row
  
  WS.Select
  oszlop = Range("XFD1").End(xlToLeft).Column
  
  'Előző cella-egyesítések megszüntetése
  Columns(1).MergeCells = False
  
  'Előző adatok törlése
  Rows("2:5000").Delete '***************
  
  'Adatok a Felvitel lapról a Munka3-ra
  WSF.Select
  Range("A2").Select
  Range(Selection, Selection.End(xlToRight)).Select
  Range(Selection, Selection.End(xlDown)).Copy WS.Range("A2")
  
  WS.Select
  
  'Rendezés
  Range(Cells(1, 1), Cells(usor, oszlop)).Select
  ActiveSheet.Sort.SortFields.Clear
  ActiveSheet.Sort.SortFields.Add Key:=Range("A2:A" & usor) _
  , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  ActiveSheet.Sort.SortFields.Add Key:=Range("C2:C" & usor) _
  , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
  With ActiveSheet.Sort
  .SetRange Range("A1:C" & usor)
  .Header = xlYes
  .MatchCase = False
  .Orientation = xlTopToBottom
  .SortMethod = xlPinYin
  .Apply
  End With
  
  'Cellaegyesítés az A oszlopban
  For sor = usor To 2 Step -1
  If Cells(sor, 1) = Cells(sor - 1, 1) Then
  Cells(sor - 1, 1) = ""
  Range(Cells(sor - 1, 1), Cells(sor, 1)).MergeCells = True
  End If
  Next
  
  'Keret
  Range(Cells(1, 1), Cells(usor, oszlop)).Select
  Selection.Borders(xlEdgeLeft).LineStyle = xlThin
  Selection.Borders(xlEdgeTop).Weight = xlThin
  Selection.Borders(xlEdgeBottom).Weight = xlThin
  Selection.Borders(xlEdgeRight).Weight = xlThin
  Selection.Borders(xlInsideVertical).Weight = xlThin
  Selection.Borders(xlInsideHorizontal).Weight = xlThin
  
  Application.ScreenUpdating = False
  End Sub

  Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.

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