W tym artykule utworzymy makro do kopiowania danych ze wszystkich arkuszy w skoroszycie do nowego arkusza.
Surowe dane dla tego przykładu składają się z danych pracowników z różnych działów w różnych arkuszach. Chcemy skonsolidować dane pracowników w jednym arkuszu.
Stworzyliśmy makro „CopyRangeFromMultipleSheets” do konsolidacji danych. To makro można uruchomić klikając przycisk „Konsoliduj dane”.
Makro utworzy nowy arkusz i wstawi skonsolidowane dane ze wszystkich arkuszy.
Wyjaśnienie kodu
„Zapętlanie” wszystkich arkuszy w celu sprawdzenia, czy istnieje arkusz „wzorcowy”.
Dla każdego źródła w ThisWorkbook.Worksheets
If Source.Name = "Master" Then
MsgBox "Karta wzorcowa już istnieje"
Wyjście Sub
Zakończ, jeśli
Następny
Powyższy kod służy do sprawdzania, czy w skoroszycie istnieje arkusz „wzorcowy”. Jeśli w skoroszycie istnieje arkusz „wzorcowy”, kod zostanie zakończony i wyświetlony zostanie komunikat o błędzie.
Source.Range("A1").SpecialCells(xlLastCell).Row
Powyższy kod służy do pobrania numeru wiersza ostatniej komórki w arkuszu.
Source.Range("A1", Range("A1").SpecialCells(xlLastCell)).Copy Destination.Range("A" & DestLastRow)
Powyższy kod służy do kopiowania określonego zakresu do zdefiniowanej komórki.
Proszę postępować zgodnie z poniższym kodem!
Sub CopyRangeFromMultipleSheets() 'Deklarowanie zmiennych Dim Source As Worksheet Dim Source As Worksheet Dim SourceLastRow, DestLastRow As Long Application.ScreenUpdating = False 'Przechodzenie przez wszystkie arkusze w celu sprawdzenia, czy istnieje arkusz „Master” Dla każdego źródła w ThisWorkbook.Worksheets If Source.Name = "Główny" Then MsgBox "Arkusz główny już istnieje" Exit Sub End If Next 'Wstawianie nowego arkusza za arkuszem "Główny" Set Destination = Worksheets.Add(after:=Sheets("Main")) Destination.Name = " Wzorzec" 'Przechodzenie przez wszystkie arkusze skoroszytu Dla każdego źródła w tym skoroszycie.Worksheets 'Zapobieganie konsolidacji danych z arkusza "Główny" i "Wzorcowy" Jeśli Źródło.Nazwa "Główna" i Źródło.Nazwa "Wzorzec" Then SourceLastRow = Źródło .Range("A1").SpecialCells(xlLastCell).Row Source.Activate Jeśli Source.UsedRange.Count > 1 Then DestLastRow = Sheets("Master").Range("A1").SpecialCells(xlLastCell).Row Jeśli DestLastRow = 1 Następnie 'kopiowanie danych z arkusza źródłowego do arkusza docelowego Source.Range("A 1", Range("A1").SpecialCells(xlLastCell)).Copy Destination.Range("A" & DestLastRow) Else Source.Range("A2", Range("A1").SpecialCells(xlCellTypeLastCell)).Copy Destination.Range("A" & (DestLastRow + 1)) End If End If End If Next Destination.Aktywuj Application.ScreenUpdating = True End Sub
Jeśli podobał Ci się ten blog, podziel się nim ze znajomymi na Facebooku. Możesz również śledzić nas na Twitterze i Facebooku.
Chcielibyśmy usłyszeć od Ciebie, daj nam znać, jak możemy poprawić naszą pracę i uczynić ją lepszą dla Ciebie. Napisz do nas na stronie e-mail