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

• #13365 Delila_1 Topikgazda jaszy83 #13364

  Új Válasz 2012-04-04 08:37:18 #13365

  Ú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

  Topikgazda

  válasz jaszy83 #13364 üzenetére

  Azt majd megmondod, mi az X és H az egyes sorokban.

  Sub Rendez_1()
  Dim sor As Long, usor As Long, oszlop As Integer, uoszlop 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
  uoszlop = 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, uoszlop)).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, "–" beírása
  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
  For oszlop = 5 To uoszlop
  If Cells(1, oszlop) < Cells(sor, 4) Then
  Cells(sor, oszlop) = "–"
  Else
  Exit For
  End If
  Next
  Next
  
  'Keret
  Range(Cells(1, 1), Cells(usor, uoszlop)).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