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

• #13350 Delila_1 veterán jaszy83 #13345

  Új Válasz 2012-03-30 12:52:44 #13350

  Ú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

  Akkor egyszerűsítsünk!

  A makró a Felvitel lapról veszi az adatokat, és a Munka3 lapra másolja át. Az új tartományt rendezi, majd egyesíti az A oszlop egyesíthető celláit, végül megadja a keretet.
  Mindezek előtt a Munka3 lapot kitakarítja a címsor kivételével.

  Nem tudom, mennyi adatod lesz, a takarítást az A2:K5000 tartományban végeztetem el. Azokat a sorokat, ahol a lapok nevén, vagy a tartományon módosítani kell, csillagokkal kommenteztem.

  Sub Rendez()
  Dim sor As Long, usor As Long, WS As Worksheet, WSF As Worksheet
  
  Set WS = Sheets("Munka3") '***************
  Set WSF = Sheets("Felvitel") '***************
  
  usor = WSF.Range("A" & Rows.Count).End(xlUp).Row
  WS.Select
  
  '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
  For sor = 2 To usor
  Cells(sor, 1) = WSF.Cells(sor, 1)
  Cells(sor, 2) = WSF.Cells(sor, 2)
  Cells(sor, 3) = WSF.Cells(sor, 3)
  Next
  
  'Rendezés
  Columns("A:K").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("A1:K" & usor).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
  End Sub

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