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

• #21549 Delila_1 veterán gobe22 #21548

  Új Válasz 2014-05-10 12:36:15 #21549

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

  Az üres sorok törlésével kezd, nem szükséges a kijelölés, azonnal futtatható. Feltételezem, hogy a txt fájlból az adatokat az A1-től kezdve másolod be.

  Sub VizszRend()
  Dim usor As Long, sor As Long
  
  Application.DisplayAlerts = False
  
  'Üres sorok törlése
  Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
  
  'Szövegből oszlopok
  usor = Application.CountA(Columns(1))
  Range("A1:A" & usor).TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
  TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
  Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
  :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
  Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1)), _
  TrailingMinusNumbers:=True
  
  'Rendezés soronként
  For sor = 1 To usor
  Rows(sor).Select
  Selection.Sort Key1:=Range("A" & sor), Order1:=xlAscending, Header:= _
  xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight, _
  DataOption1:=xlSortNormal
  Next
  
  'Összefűzés az N oszlopban
  Range("N1:N" & usor).FormulaR1C1 = _
  "=RC[-13]&"",""&RC[-12]&"",""&RC[-11]&"",""&RC[-10]&"",""&RC[-9]&"",""&RC[-8]&"",""&RC[-7]&"",""&RC[-6]&"",""&RC[-5]&"",""&RC[-4]&"",""&RC[-3]&"",""&RC[-2]"
  
  'N oszlop irányított beillesztése az A-ba
  Range("N:N").Copy
  Range("A1").PasteSpecial xlPasteValues
  
  'Segédoszlopok törlése
  Range("B:N").ClearContents
  
  'Többszörös vesszők törlése
  sor = 0
  Do While sor < 3
  Cells.Replace What:=",,", Replacement:="", LookAt:=xlPart, SearchOrder _
  :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
  sor = sor + 1
  Loop
  
  'Utolsó vessző törlése képlettel a H oszlopba
  Range("H1:H" & usor).FormulaR1C1 = _
  "=IF(RIGHT(RC[-7],1)="","",LEFT(RC[-7],LEN(RC[-7])-1),RC[-7])"
  
  'H oszlop másolása az A-ba
  Range("H:H").Copy
  Range("A1").PasteSpecial xlPasteValues
  Range("H:H").ClearContents 'H oszlop törlése
  
  Application.DisplayAlerts = False
  End Sub

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