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: 75835 Skopiuj do schowka Funkcja przenosząca wiersze do odpowiednich arkuszy
Autor Wiadomość
kropekreniek 
Forumowicz


Wersja: Win Office 2021
Posty: 17
Wysłany: 12-05-2024, 14:19   Funkcja przenosząca wiersze do odpowiednich arkuszy

Cześć,

Mój obecny problem polega na tym, że chciałbym skopiować cały wiersz z arkusza "Lista Mag" na podstawie wartości z kolumny D "Opis Magazyn" do odpowiadającej mu nazwie magazynu tj. tam gdzie mamy w kol. D wartość Magazyn 1 do kopiujemy cały wiersz do arkusza "Magazyn 1" itd. Napisałem sobie taką funkcje jak poniżej (jak na razie jedyne co działa to przenoszenie pojedyńczej wartości do odpowiedniej nazwy magazynu) ale mam z nią dwa problemy :
1. Nie wiem jak przenieść cały wiersz do odpowiedniego arkusza magazynu.
2. Jak zrobić by kopiowane wartości do poszczególnych arkuszy następowały dokładnie po sobie. może, można by zastosować activeCell.Offset ale z tego co już wiem, powinno się tego unikać bo wpływa to na wydajność przy arkuszach z dużą ilością rekordów i to chyba jest zła praktyka przy pisaniu makr.
W pliku zamieszczam, makro oraz arkusze z formą jaką chciałbym uzyskać.

Byłbym wdzięczny za pomoc.

Kod:
Function MoveRow(MagName As String, CurrRow As Range) As String
    Dim ShName As Worksheet
    For Each ShName In ThisWorkbook.Worksheets
        If ShName.Name = MagName Then
            ThisWorkbook.Worksheets(MagName).Range("A1").Value = MagName
            Exit For
        End If
   
    Next ShName
   
End Function

Sub PrzeniesMag()
Dim RowNumMagS As Long
Dim MagName As String
Dim ArName As String
Dim CurrRow As Range
RowNumMagS = Range("C1", Range("C1").End(xlDown)).Rows.Count

For i = 2 To RowNumMagS
    Set CurrRow = Range("D" & i).EntireRow ' aktualny wiersz
    MagName = Cells(i, "D").Value ' nazwa magazynu
   
    MoveRow MagName, CurrRow ' wywołanie funkcji, która ma mi przenosić wiersz do odpowiednich arkuszy po wartości kol. D
   
Next i

End Sub


Forum Pytanie.xlsm
Pobierz Plik ściągnięto 15 raz(y) 21.36 KB

ID posta: 435298 Skopiuj do schowka
 
 
hurgadion 
ExcelSpec



Wersja: Win Office 2021
Pomógł: 1194 razy
Posty: 2746
Wysłany: 12-05-2024, 17:21   

Hej,
spróbuj odpalić następujące makro:
Kod:

Sub Przekopiuj()
Dim i&, a&, b&, wks As Worksheet

For Each wks In Worksheets
   If wks.Name <> "Lista Mag" Then
     a = wks.Cells(wks.Rows.Count, 4).End(xlUp).Row
     wks.Range("A2:G" & a).Clear
   End If
Next wks

For i = 2 To Cells(Rows.Count, 4).End(xlUp).Row
   With Worksheets(Cells(i, 4).Value)
      b = .Cells(.Rows.Count, 4).End(xlUp).Row
      Range("A" & i & ":G" & i).Copy .Range("A" & b + 1)
   End With
Next i
End Sub

Pozdrawiam :lol:

Forum Pytanie.sol.xlsm
Pobierz Plik ściągnięto 16 raz(y) 28.17 KB

ID posta: 435299 Skopiuj do schowka
 
 
Tajan


Pomógł: 5480 razy
Posty: 11920
Wysłany: 12-05-2024, 20:59   

Nieco inny przykład rozwiązania działający na zasadzie grupowego kopiowania wierszy. Może być przydatny w przypadku konieczności działania w większej liczbie wierszy gdyż będzie szybszy od działania na pojedynczych wierszach:
Kod:
Sub PrzeniesMag_1()

    Dim kryteria As Range
    Dim kom As Range
    Dim rng As Range
 
    With Range("A1").CurrentRegion

        .Columns("D").AdvancedFilter xlFilterInPlace, Unique:=True
         
        With Range("_filterDatabase")
            Set kryteria = .Offset(1, 0).Resize(.Count - 1).SpecialCells(xlVisible)
        End With
     
        For Each kom In kryteria

            If kom.Value <> "" Then
           
                .AutoFilter Field:=4, Criteria1:=kom.Value
               
                Set rng = .Offset(1).SpecialCells(xlVisible).EntireRow
               
                With Worksheets(kom.Value)
                    rng.Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
                End With
                 
            End If
     
        Next

        .AutoFilter

    End With

End Sub
ID posta: 435301 Skopiuj do schowka
 
 
kropekreniek 
Forumowicz


Wersja: Win Office 2021
Posty: 17
Wysłany: 18-05-2024, 19:27   

Dzięki za propozycje rozwiązania.

Hurgadion - Twoje rozwiązanie jak najbardziej działa ale kiedy puściłem to na kilkudziesięciu tysiącach rekordów, makro strasznie długo to "miele" ( czekałem 5 min. i wyłączyłem). W każdym razie Twój kod i tak jest dla mnie przydatny, bo pokazał mi rozwiązanie jak wiersze mają być kopiowane do arkusza po sobie.

Co do rozwiązania Tajana to jeszcze go nie testowałem. Dam znać jak to zaimplementuje do swojego kodu.

Dziękuje Panowie za poświęcony czas i chęć pomocy.
ID posta: 435403 Skopiuj do schowka
 
 
kropekreniek 
Forumowicz


Wersja: Win Office 2021
Posty: 17
Wysłany: 03-06-2024, 10:07   

Dzięki wielkie Tajan, Twoje rozwiązania działa wręcz błyskawicznie na wielu rekordach. Co prawda, średnio rozumiem Twój kod, ale może metodą prób i błędów to ogarnę. Jeszcze raz dzięki!
ID posta: 435637 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