Hirdetés

  2. Fórumok
  3. OS, alkalmazások
  4. Microsoft Excel topic
  5. (kiemelt téma)
  • Téma összefoglaló
    Utoljára frissítve: 2023-11-13 08:31

    PROHARDVER!

    A Microsoft Excel topic célja segítséget kérni és nyújtani Excellel kapcsolatos problémákra.
    Kérdés felvetése előtt olvasd el, ha még nem tetted.

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

  • #21549 Delila_1 veterán gobe22 #21548
    Új Válasz #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