[grzesioi]

Witam,
potrzebuję makro bądź formułę która oddzieliłaby dane z komórek do osobnych wierszy.
(potrzebuję żeby każdy nr był w osobnej komórce)

---

Zeszyt2.xlsx

Pobierz Plik ściągnięto 13 raz(y) 136.67 KB

[Bill Szysz]

grzesioi, tyle postów ale wersji excela nie raczyłeś wpisać. Jak zapewne wiesz, są ogromne różnice miedzy 365 i 2021 a resztą wersji.
Tu masz rozwiązanie dostosowane do nowych wersji excela - wykorzystałem nowe funkcje i własne, zdefiniowane przy pomocy LAMBDA ( w tym jedna rekurencyjna ale ukryta bo wewnętrznie korzysta z niej funkcja SPLIT). Działa błyskawicznie.

---

Rozwinięcie_BS.xlsx

Pobierz Plik ściągnięto 10 raz(y) 332.49 KB

[xfish]

Załącznik zrobione w Power Query

---

Kopia Zeszyt2.xlsx

Pobierz Plik ściągnięto 11 raz(y) 386.12 KB

[grzesioi]

[xfish]

W moim rozwiązaniu jest użyta tabela.
Gdy zwiększysz jej zakres (W H3880 w prawym dolnym rogu jest taki mały uchwyt - przeciągnij go w dół tak żeby tabela objęła cały zakres) i odświeżysz tabelę w Arkusz2, wszystko powinno zadziałać.

[kuma]

Proponuję VBA.
Wyniki są w arkuszu nr 2 (musisz go dodać).

Kod:

Sub test_kuma()     Dim a     Dim w As Variant         a = Application.Transpose(Sheets(1).[h2].CurrentRegion)     w = Join(a, vbLf)     w = Replace(w, vbLf, " '")     w = Split(w, " ")     Sheets(2).[a1].Resize(UBound(w)) = Application.Transpose(w) End Sub

[Maciej Gonet]

Ode mnie też propozycja VBA. Kod trochę dłuższy niż u kumy, ale uwzględnia pomijanie duplikatów (zakładam, podobnie jak Bill Szysz, że powinny być usunięte).

Liczba wierszy jest ograniczona do 100 000. Można to zmienić, można też powiększać tablicę wyników dynamicznie, ale to wydłuży nieco kod i czas wykonania.
Założyłem, że dane są w stałym miejscu od H2 w dół, natomiast wyniki będą umieszczone od miejsca ustawienia kursora w dół.

Kod:

Sub Podziel_na_wiersze()    ' zakres źródłowy    Dim ostw As Long, zrv As Variant    ostw = Cells(Rows.Count, "H").End(xlUp).Row    zrv = Range("H2:H" & ostw).Value    Dim Start    Start = Timer        ' tworzenie kolekcji i tablicy wyników    Dim Bcode As New Collection    Dim wi    Dim i As Long, j As Long, k As Long        Dim wyn() As String    ReDim wyn(1 To 100000, 1 To 1)     ' max. 100 000 wierszy        On Error Resume Next    For i = 1 To ostw - 1       wi = Split(zrv(i, 1), vbLf)       For j = 0 To UBound(wi)          Bcode.Add wi(j), wi(j)          If Err Then             Err.Clear          Else             k = k + 1             wyn(k, 1) = wi(j)          End If       Next j    Next i        ' kasowanie miejsca na wynik    Range(Selection(1), Cells(Rows.Count, Selection(1).Column).End(xlUp)).ClearContents        ' zapis tablicy wyn do arkusza w miejscu kursora    Selection(1).Resize(k) = wyn    Set Bcode = Nothing    Debug.Print Timer - Start End Sub

---

Zeszyt2-do_osobnych_wierszy.xlsm

Pobierz Plik ściągnięto 9 raz(y) 381.74 KB

[grzesioi]