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

Recently Active Members

Profile picture of vbatools
Profile picture of Karol Stilger
Profile picture of Joanna Subik
Profile picture of Anorak
Profile picture of marcinmachalowski
Profile picture of programistaaccess
Profile picture of piotrpawlik
Profile picture of Emil Wasilewski
Profile picture of kicekpicek
Profile picture of coldfusion
Profile picture of Gosia Borzęcka
Profile picture of lukaszch
Profile picture of itadministracja
Profile picture of farbenia
Profile picture of Łukasz Kałużny
Profile picture of kabzinski
Profile picture of rtynski
Profile picture of leszekbetlinski
Profile picture of Iv
Profile picture of Justyna Spychała