Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
ID tematu: 73305 Skopiuj do schowka Rozdzielenie danych w odobne komórki
Autor Wiadomość
grzesioi 
Exceloholic


Wersja: Win Office 2010
Posty: 187
Wysłany: 31-08-2022, 15:07   Rozdzielenie danych w odobne komórki

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 11 raz(y) 136.67 KB

ID posta: 420181 Skopiuj do schowka
 
 
Bill Szysz 
Excel Expert


Wersja: Win Office 365
Pomógł: 1004 razy
Posty: 3923
Wysłany: 31-08-2022, 15:40   

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 8 raz(y) 332.49 KB

_________________
Zlecenia, konsultacje, doradztwo i szkolenia z Power Query, Power BI i Excela - Raporty, Analizy, Projekty
Pozdrawiam, były szbill62 aktualnie Bill Szysz
ID posta: 420183 Skopiuj do schowka
 
 
xfish 
Excel Expert



Wersja: Win Office 2013
Pomógł: 702 razy
Posty: 2087
Wysłany: 01-09-2022, 07:15   

Załącznik zrobione w Power Query

Kopia Zeszyt2.xlsx
Pobierz Plik ściągnięto 8 raz(y) 386.12 KB

_________________
Pozdrawiam xFish
ID posta: 420202 Skopiuj do schowka
 
 
grzesioi 
Exceloholic


Wersja: Win Office 2010
Posty: 187
Wysłany: 01-09-2022, 07:53   

Bill Szysz napisał/a:
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.


Już się poprawiłem.
Jak dodam jakieś kolejne nr w kolumnie H to jak mam zwiększyć zakres przeliczania formuły? Bo próbowałem kopiować formułę i mam błąd ( #NAZWA? )

xfish napisał/a:
Załącznik zrobione w Power Query

i tu też nie wiem jak mam zwiększyć zakres przeliczania po dodaniu nowych numerów.
ID posta: 420205 Skopiuj do schowka
 
 
xfish 
Excel Expert



Wersja: Win Office 2013
Pomógł: 702 razy
Posty: 2087
Wysłany: 01-09-2022, 08:57   

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ć.
_________________
Pozdrawiam xFish
ID posta: 420207 Skopiuj do schowka
 
 
kuma 
Excel Expert


Wersja: Win Office 2010
Pomógł: 1513 razy
Posty: 4323
Wysłany: 01-09-2022, 10:10   

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
_________________
Pozdrawiam.
ID posta: 420210 Skopiuj do schowka
 
 
Maciej Gonet 
Excel Expert


Wersja: Win Office 365
Pomógł: 2828 razy
Posty: 8516
Wysłany: 01-09-2022, 11:50   

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 7 raz(y) 381.74 KB

ID posta: 420212 Skopiuj do schowka
 
 
grzesioi 
Exceloholic


Wersja: Win Office 2010
Posty: 187
Wysłany: 01-09-2022, 14:58   

Maciej Gonet napisał/a:
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


dzięki, to rozwiązanie najradziej mi przypadło do gustu. :)
ID posta: 420221 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.wip.pl

Archiwum

Strona używa plików cookies.

Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe