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

• #21552 Delila_1 veterán gobe22 #21550

  Új Válasz 2014-05-10 12:47:39 #21552

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

  Hagyok Neked is egy kis munkát.

• #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

• #21548 gobe22 csendes tag gobe22 #21547

  Új Válasz 2014-05-10 12:15:17 #21548

  Ú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

  

  gobe22

  csendes tag

  válasz gobe22 #21547 üzenetére

  Kiszedtem az üres sorokat, így már tökjól műxik.
  Még esetleg ki lehet egészíteni azzal, hogy az üres sorokat hagyja változatlanul?
  Ugye akármilyen sok sorból álló adatoknál is műxik, ugye?

• #21546 Delila_1 veterán gobe22 #21543

  Új Válasz 2014-05-10 11:41:30 #21546

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

  Kicsit sok volt a buktató.
  Kijelölöd a tartományt az A oszlopban, és indítod a makrót.

  Sub VizszRend()
  Dim usor As Long, sor As Long
  
  Application.DisplayAlerts = False
  
  'Szövegből oszlopok
  Selection.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
  usor = Application.CountA(Columns(1))
  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

• #21542 Delila_1 veterán gobe22 #21540

  Új Válasz 2014-05-10 10:30:35 #21542

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

  Hány vesszővel ellátott adatod van soronként? Írok rá egy makrót.

• #21538 Delila_1 veterán gobe22 #21536

  Új Válasz 2014-05-10 10:18:10 #21538

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

  Próbáld újra, nálam nincs egy zokszava, megcsinálja.

• #21533 Delila_1 veterán gobe22 #21530

  Új Válasz 2014-05-10 10:11:31 #21533

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

  Több lépésben lehet megoldani.

  1. Kijelölöd a tartományt, a Szövegből oszlopok funkcióval oszlopokra bontod a szöveget, ahol határoló jelnek a vesszőt jelölöd be.
  2. Újra kijelölöd a kibővült tartományt, Rendezés. Itt az Egyebek-nél a Balról jobbra funkciót választod.
  3. Ezután újra összefűzöd az adatokat egy segédoszlopban, közöttük vesszővel: =A1 & "," & B1 & "," & C1 stb., ahány oszlopra bontotta szét a Szövegből oszlopok.
  4. A segédoszlopot másolod, és az eredeti helyére illeszted be irányítottan, értékként.
  5. Törlöd a feleslegessé vált oszlopokat, csak az A maradjon meg.

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