Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - Funkcja przenosząca wiersze do odpowiednich arkuszy

kropekreniek · Forumowicz Wersja: Win Office 365 Posty: 23

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

hurgadion · 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 40 raz(y) 28.17 KB

Tajan · **Pomógł:** 5618 razy Posty: 12152

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

kropekreniek · Forumowicz Wersja: Win Office 365 Posty: 23

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.

kropekreniek · Forumowicz Wersja: Win Office 365 Posty: 23

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!