VBATools

Agregacja wszystkich arkuszy skoroszytu

by 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.
:, , , ,

Leave a Reply