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: 70116 Skopiuj do schowka Skopiowanie danych do osobnych arkuszy
Autor Wiadomość
mondii 
Forumowicz


Wersja: Win Office 365
Posty: 13
Wysłany: 11-02-2021, 11:42   Skopiowanie danych do osobnych arkuszy

Witam serdecznie,

Borykam się z następującym problemem. Chciałbym np. za pomocą makra spowodować aby dane występujące w pliku Z1 (dla nieskończonej ilości wierszy) skopiowały się do nowych arkuszy w zależności od różnych wartości w kolumnie JO.

Tak jak wygląda to w pliku , który zrobiłem ręcznie Z2 (łącznie z nazwami arkuszy).

Dziękuję za pomoc

Z1.xlsx
Pobierz Plik ściągnięto 7 raz(y) 9.4 KB

Z2.xlsx
Pobierz Plik ściągnięto 8 raz(y) 11.65 KB

ID posta: 400156 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 3133 razy
Posty: 10378
Wysłany: 11-02-2021, 14:13   

1. Czy musi istnieć pusty wiersz w tabeli (wiersz nr 2)?
2. Jeśli TAK, to czy występuje zawsze?
3. Rozbicie na arkusze ma nastąpić w tym samym pliku, czy w nowym?
4.
mondii napisał/a:
Tak jak wygląda to w pliku , który zrobiłem ręcznie Z2 (łącznie z nazwami arkuszy).
Skoroszyt Z2 zawiera standardowe nazwy arkuszy. Więc o co chodzi z tymi nazwami?

Artik
_________________
Persistence is a virtue in the world of programming.
ID posta: 400181 Skopiuj do schowka
 
 
kuma 
Excel Expert


Wersja: Win Office 2010
Pomógł: 1453 razy
Posty: 4169
Wysłany: 11-02-2021, 18:01   

Zrozumiałem to tak jak w moim kodzie - nazwy arkuszy są nazwami unikatami z kol. B (JO).
Kod:
Sub test_kuma()
    Dim a(), hdrs, rws, k
    Dim i As Integer, r As Integer

    With Sheets("Arkusz1")
        hdrs = .[a1].CurrentRegion
        a = .UsedRange.Value
    End With
    With VBA.CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a)
            If a(i, 1) <> "" Then
                If .exists(a(i, 2)) Then
                    .Item(a(i, 2)) = .Item(a(i, 2)) & "," & i
                Else
                    .Item(a(i, 2)) = i
                End If
            End If
        Next
        Application.ScreenUpdating = False
        For Each k In .keys
            rws = Application.Transpose(Split(.Item(k), ","))
            ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = k
            With ActiveSheet.[a1]
                .Resize(, UBound(hdrs, 2)) = hdrs
                .Offset(1).Resize(UBound(rws), UBound(hdrs, 2)).Value = Application.Index(a, rws, Array(1, 2, 3, 4))
               
                'gdy miało być numerowanie od 1 zdejmij komentarz z 2 linii poniżej (usuń apostrof na początku)
'                r = .CurrentRegion.Rows.Count - 1
'                .Offset(1).Resize(r) = Evaluate("row(1:" & r & ")")
            End With
        Next
    End With
End Sub
_________________
Pozdrawiam.
ID posta: 400205 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.marketingNET.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