Agregacja wszystkich arkuszy skoroszytu
by vbatools on Nov.08, 2011, under Excel, Porady
Posiadając większą ilość arkuszy w skoroszycie scalenie ich po przez zaznaczanie obszaru i klejenie w miejsce przeznaczenia jest pracą dość mozolną. Aby tego dokonać w sposób zautomatyzowany można wykorzystać makro.
Do jego skonstruowania wykorzystałem funkcję kolegi Rona oraz właściwości tablicowe. Aby przygotować się do agregacji należy określić arkusz docelowy (niżej nazwany “docelowy”), który należy utworzyć – lub zastąpić nazwę arkusza na inny.
Option Explicit Sub Agregacja_arkuszy_skoroszytu() 'MVP OShon VBATools.pl Dim wks As Worksheet, Arkusz_docelowy As Worksheet Dim LastRow&, max_row&, max_col&, dane As Variant On Error GoTo blad Set Arkusz_docelowy = Sheets("docelowy") 'Nazwa arkusza docelowego Arkusz_docelowy.Cells.ClearContents 'czyszczenie danych arkusza doc. Application.ScreenUpdating = False For Each wks In ThisWorkbook.Worksheets With wks If .Name <> Arkusz_docelowy.Name Then LastRow = Last_Row_Col(Arkusz_docelowy.Range(Arkusz_docelowy.Cells(1, 1), _ Arkusz_docelowy.Cells.SpecialCells(xlLastCell))) max_row = Last_Row_Col(.Range(.Cells(1, 1), .Cells.SpecialCells(xlLastCell))) max_col = Last_Row_Col(.Range(.Cells(1, 1), .Cells.SpecialCells(xlLastCell)), True) If max_row = 0 Then GoTo pusty dane = .Range(.Range("a1"), .Cells(max_row, max_col)) Arkusz_docelowy.Cells(LastRow + 1, 1).Resize(UBound(dane), max_col) = dane End If End With pusty: Next wks Set Arkusz_docelowy = Nothing Application.ScreenUpdating = True Beep Exit Sub blad: Application.ScreenUpdating = True MsgBox Err.Number & " " & Err.Description, vbCritical, "Informacja o błędzie VBATools.pl" End Sub Function Last_Row_Col(rng As Excel.Range, Optional col As Boolean) As Long ' wg. Ron de Bruin, 20 Feb 2007 ' http://www.rondebruin.nl/last.htm ' mod by OShon VBATools.pl On Error Resume Next Select Case col Case False Last_Row_Col = rng.Find(What:="*", _ After:=rng.Cells(1), _ LookAt:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row Case True Last_Row_Col = rng.Find(What:="*", _ After:=rng.Cells(1), _ LookAt:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Column End Select On Error GoTo 0 End Function
Dla tych, którzy nie radzą sobie z okiełznaniem kodu VBA lub po prostu, chcieli by posiadać uniwersalne narzędzie, posiadające również inne możliwości – polecam dodatek Łączenie Arkuszy
(c) Shon Oskar – www.VBATools.pl
Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.