Każdy, kto pracuje w finansach, zna ten moment: trzeba przygotować raport konsolidacyjny.
Dane spływają z różnych oddziałów, tysiące wierszy w arkuszu „dane”, a w „zestawieniu kosztów” ma się pojawić podsumowanie. Tyle że zawsze coś się rozjedzie w jednym miejscu brakuje liczby, w drugim ktoś źle przepisał koszt. Ręczne sprawdzanie tego wszystkiego zajmowało godziny.
Dlatego powstało makro VBA, które robi tę pracę automatycznie.
Makro zaczyna od odszukania właściwych arkuszy. Nie musimy podawać ich nazw na sztywno zatem wystarczy, że w nazwie zakładki jest słowo „dane” albo „zestawienie kosztów”.
Option Explicit ’ Wymusza deklarowanie zmiennych (chroni przed literówkami)
’========================
’ Funkcje pomocnicze
’========================
Private Function ColByName(sh As Worksheet, nm As String) As Long
’ Szuka w wierszu 1 nagłówka zawierającego fragment nm
’ Zwraca numer kolumny, 0 jeżeli nie znajdzie
Dim c As Range
Set c = sh.Rows(1).Find(What:=nm, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
If Not c Is Nothing Then ColByName = c.Column
End Function
Private Function Nz(v, Optional d As Double = 0) As Double
’ Bezpieczna konwersja: błędy/puste/tekst -> d (domyślnie 0), liczby -> CDbl
If IsError(v) Or IsEmpty(v) Or v = „” Then
Nz = d
ElseIf IsNumeric(v) Then
Nz = CDbl(v)
Else
Nz = d
End If
End Function
’========================
’ RAPORT: budowa zestawienia od zera
’========================
Public Sub Raport_OK()
Dim shD As Worksheet, shZ As Worksheet, ws As Worksheet
' Automatyczne wyszukanie arkuszy po fragmencie nazwy
For Each ws In ThisWorkbook.Worksheets
If InStr(1, LCase(ws.Name), "dane") > 0 Then Set shD = ws
If InStr(1, LCase(ws.Name), "zestawienie") > 0 And InStr(1, LCase(ws.Name), "koszt") > 0 Then Set shZ = ws
Next ws
' Jeżeli nie ma któregoś z arkuszy – zakończ
If shD Is Nothing Or shZ Is Nothing Then Exit Sub
' Ustalenie numerów kolumn po nagłówkach
Dim cKGW As Long, cData As Long, cP As Long, cK As Long, cR As Long, cKon As Long
cKGW = ColByName(shD, "Numer KGW")
cData = ColByName(shD, "Data")
cP = ColByName(shD, "Początkowa wartość")
cK = ColByName(shD, "Koszt")
cR = ColByName(shD, "Rozchod")
cKon = ColByName(shD, "Końcowa wartość")
' Ostatni wiersz na podstawie kolumny KGW
Dim lastRow As Long
lastRow = shD.Cells(shD.Rows.Count, cKGW).End(xlUp).Row
' Struktury agregujące
Dim dict1 As Object, uniq56 As Object
Set dict1 = CreateObject("Scripting.Dictionary") ' klucz: 8-znakowy prefiks KGW; val: [minData,sumP,sumK,sumR,sumKon]
Set uniq56 = CreateObject("Scripting.Dictionary") ' zbiór unikalnych KGW zakończonych na "56"
Dim M(1 To 5, 1 To 9) As Double ' macierz: rodzaje 52..56 → 1..5; województwa 1..9
' Przejście po wierszach danych
Dim r As Long
For r = 2 To lastRow
Dim nf As String
nf = Trim$(CStr(shD.Cells(r, cKGW).Value)) ' pełny numer KGW w wierszu
If nf <> "" Then
Dim s8 As String
s8 = Left$(nf, 8) ' prefiks 8-znakowy – klucz grupy
' Inicjalizacja grupy przy pierwszym trafieniu
If Not dict1.Exists(s8) Then dict1.Add s8, Array(shD.Cells(r, cData).Value, 0#, 0#, 0#, 0#)
Dim v As Variant
v = dict1(s8) ' v(0)=minData; v(1)=sumP; v(2)=sumK; v(3)=sumR; v(4)=sumKon
' Najstarsza (minimalna) data w grupie
If v(0) = 0 Or v(0) > shD.Cells(r, cData).Value Then v(0) = shD.Cells(r, cData).Value
' Sumowanie wartości z wiersza (zabezpieczenie Nz)
v(1) = v(1) + Nz(shD.Cells(r, cP).Value) ' początkowa
v(2) = v(2) + Nz(shD.Cells(r, cK).Value) ' koszt
v(3) = v(3) + Nz(shD.Cells(r, cR).Value) ' rozchód
v(4) = v(4) + Nz(shD.Cells(r, cKon).Value) ' końcowa
dict1(s8) = v
' Dekodowanie województwa i rodzaju z numeru KGW
Dim woj As Long, rodz As Long, idx As Long
woj = Val(Left$(nf, 1)) ' pierwsza cyfra → województwo (1..9)
rodz = Val(Right$(nf, 2)) ' dwie ostatnie → rodzaj (52..56)
idx = rodz - 51 ' 52→1 ... 56→5
' Sumowanie kosztów do macierzy M(rodzaj, województwo)
If idx >= 1 And idx <= 5 And woj >= 1 And woj <= 9 Then
M(idx, woj) = M(idx, woj) + Nz(shD.Cells(r, cK).Value)
End If
' Zbieranie unikalnych KGW kończących się na "56"
If Right$(nf, 2) = "56" Then uniq56(nf) = 1
End If
Next r
' Sort kluczy (prefiksy s8 rosnąco)
Dim keys() As Variant, i As Long, j As Long, tmp
keys = dict1.Keys
If UBound(keys) >= 0 Then
For i = LBound(keys) To UBound(keys) - 1
For j = i + 1 To UBound(keys)
If keys(j) < keys(i) Then
tmp = keys(i): keys(i) = keys(j): keys(j) = tmp
End If
Next j
Next i
End If
' Czyszczenie obszaru wyników w zestawieniu
shZ.Range("A3:F100000").ClearContents
' Zapis wyników grupy s8 do zestawienia
Dim rowOut As Long
rowOut = 3
For i = LBound(keys) To UBound(keys)
Dim vv As Variant
vv = dict1(keys(i))
shZ.Cells(rowOut, 1).Value = keys(i) ' klucz s8
shZ.Cells(rowOut, 2).Value = vv(0) ' najstarsza data
shZ.Cells(rowOut, 3).Value = Round(vv(1), 2) ' suma P
shZ.Cells(rowOut, 4).Value = Round(vv(2), 2) ' suma K
shZ.Cells(rowOut, 5).Value = Round(vv(3), 2) ' suma R
shZ.Cells(rowOut, 6).Value = Round(vv(4), 2) ' suma Kon
rowOut = rowOut + 1
Next i
' Wstawianie macierzy M do tabeli 52..56 × województwa
Dim r52 As Range, hdrRow As Long, baseRow As Long, sumRow As Long
Set r52 = shZ.Columns(8).Find(What:=52, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False) ' szukamy w kol. H liczby 52
If r52 Is Nothing Then Exit Sub
baseRow = r52.Row ' pierwszy wiersz z "52"
hdrRow = baseRow - 1 ' wiersz nagłówków z numerami województw
sumRow = baseRow + 5 ' wiersz sum (po 5 wierszach: 52..56)
' Zmapowanie kolumn nagłówków 1..9 do ich indeksów w arkuszu
Dim wojCol(1 To 9) As Long
For j = 1 To 9
Dim c As Range
Set c = shZ.Rows(hdrRow).Find(What:=j, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not c Is Nothing Then wojCol(j) = c.Column
Next j
' Czyszczenie bloku wyników województw
shZ.Range(shZ.Cells(baseRow, 9), shZ.Cells(sumRow, 17)).ClearContents
' Wpisanie M(rodzaj, woj) do odpowiednich komórek
For i = 1 To 5 ' 52..56
For j = 1 To 9 ' woj 1..9
If wojCol(j) > 0 Then
shZ.Cells(baseRow + i - 1, wojCol(j)).Value = Round(M(i, j), 2)
End If
Next j
Next i
' Sumy kolumn województw (wiersz sumRow)
For j = 1 To 9
Dim s As Double
s = 0
For i = 1 To 5
s = s + M(i, j)
Next i
If wojCol(j) > 0 Then shZ.Cells(sumRow, wojCol(j)).Value = Round(s, 2)
Next j
' Licznik unikalnych KGW kończących na "56" w L16
shZ.Range("L16").Value = uniq56.CountEnd Sub
’========================
’ WALIDACJA: porównanie zestawienia ze źródłem
’========================
Public Sub Walidacja_Prosta()
Dim shD As Worksheet, shZ As Worksheet, ws As Worksheet
' Ponowne znalezienie arkuszy
For Each ws In ThisWorkbook.Worksheets
If InStr(1, LCase(ws.Name), "dane") > 0 Then Set shD = ws
If InStr(1, LCase(ws.Name), "zestawienie") > 0 And InStr(1, LCase(ws.Name), "koszt") > 0 Then Set shZ = ws
Next ws
If shD Is Nothing Or shZ Is Nothing Then Exit Sub
' Alternatywny sposób na kolumny: Find bezpośrednio (równoważne ColByName)
Dim cKGW As Long, cData As Long, cP As Long, cK As Long, cR As Long, cKon As Long
cKGW = shD.Rows(1).Find("Numer KGW", , xlValues, xlPart).Column
cData = shD.Rows(1).Find("Data", , xlValues, xlPart).Column
cP = shD.Rows(1).Find("Początkowa wartość", , xlValues, xlPart).Column
cK = shD.Rows(1).Find("Koszt", , xlValues, xlPart).Column
cR = shD.Rows(1).Find("Rozchod", , xlValues, xlPart).Column
cKon = shD.Rows(1).Find("Końcowa wartość", , xlValues, xlPart).Column
' Ostatni wiersz
Dim lastRow As Long
lastRow = shD.Cells(shD.Rows.Count, cKGW).End(xlUp).Row
' Słowniki do walidacji (oddzielne od tych w Raport_OK)
Dim dict As Object, uniq56 As Object
Set dict = CreateObject("Scripting.Dictionary")
Set uniq56 = CreateObject("Scripting.Dictionary")
' Macierz M ponownie – policzymy ją niezależnie
Dim M(1 To 5, 1 To 9) As Double
' Zmienne na bieżąco w pętli
Dim r As Long, nf As String, s8 As String, v As Variant, woj As Long, rodz As Long, idx As Long
' Budowanie słownika i macierzy na podstawie źródła (jak w Raport_OK)
For r = 2 To lastRow
nf = Trim$(CStr(shD.Cells(r, cKGW).Value))
If nf <> "" Then
s8 = Left$(nf, 8)
If Not dict.Exists(s8) Then dict.Add s8, Array(shD.Cells(r, cData).Value, 0#, 0#, 0#, 0#)
v = dict(s8)
' Min data
If v(0) = 0 Or v(0) > shD.Cells(r, cData).Value Then v(0) = shD.Cells(r, cData).Value
' Sumy (tu jawna konwersja z zamianą przecinków na kropki)
v(1) = v(1) + CDbl(Val(Replace(CStr(shD.Cells(r, cP).Value), ",", ".")))
v(2) = v(2) + CDbl(Val(Replace(CStr(shD.Cells(r, cK).Value), ",", ".")))
v(3) = v(3) + CDbl(Val(Replace(CStr(shD.Cells(r, cR).Value), ",", ".")))
v(4) = v(4) + CDbl(Val(Replace(CStr(shD.Cells(r, cKon).Value),",", ".")))
dict(s8) = v
' Macierz M (koszty wg rodzaj×woj)
woj = Val(Left$(nf, 1))
rodz = Val(Right$(nf, 2))
idx = rodz - 51
If idx >= 1 And idx <= 5 And woj >= 1 And woj <= 9 Then
M(idx, woj) = M(idx, woj) + CDbl(Val(Replace(CStr(shD.Cells(r, cK).Value), ",", ".")))
End If
' Zbiór unikalnych z końcówką "56"
If Right$(nf, 2) = "56" Then uniq56(nf) = 1
End If
Next r
' Licznik błędów i tolerancja
Dim errs As Long, tol As Double
tol = 0.01
' Porównanie sekcji A: wiersze 3.. do pierwszej pustej w kolumnie A
Dim rowT1 As Long
rowT1 = 3
Do While CStr(shZ.Cells(rowT1, 1).Value) <> ""
s8 = CStr(shZ.Cells(rowT1, 1).Value) ' klucz z zestawienia
If dict.Exists(s8) Then
v = dict(s8)
' Porównania kolumn 3..6 (sumy) z zaokrągleniem do 2 miejsc i tolerancją
If Abs(shZ.Cells(rowT1, 3).Value - Round(v(1), 2)) > tol Then shZ.Cells(rowT1, 3).Interior.Color = vbYellow: errs = errs + 1
If Abs(shZ.Cells(rowT1, 4).Value - Round(v(2), 2)) > tol Then shZ.Cells(rowT1, 4).Interior.Color = vbYellow: errs = errs + 1
If Abs(shZ.Cells(rowT1, 5).Value - Round(v(3), 2)) > tol Then shZ.Cells(rowT1, 5).Interior.Color = vbYellow: errs = errs + 1
If Abs(shZ.Cells(rowT1, 6).Value - Round(v(4), 2)) > tol Then shZ.Cells(rowT1, 6).Interior.Color = vbYellow: errs = errs + 1
Else
' Brak klucza w źródle – cały blok 3..6 na czerwono
shZ.Range(shZ.Cells(rowT1, 3), shZ.Cells(rowT1, 6)).Interior.Color = vbRed: errs = errs + 4
End If
rowT1 = rowT1 + 1
Loop
' Porównanie sekcji B: tabela 52..56 × woj (w kolumnie 8 szukamy "52")
Dim r52 As Range
Set r52 = shZ.Columns(8).Find(What:=52, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not r52 Is Nothing Then
Dim baseRow As Long: baseRow = r52.Row
Dim hdrRow As Long: hdrRow = baseRow - 1
Dim sumRow As Long: sumRow = baseRow + 5
' Kolumny województw 1..9
Dim wojCol(1 To 9) As Long, j As Long, i As Long
For j = 1 To 9
Dim c As Range
Set c = shZ.Rows(hdrRow).Find(What:=j, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not c Is Nothing Then wojCol(j) = c.Column
Next j
' Sprawdzenie poszczególnych komórek M
For i = 1 To 5
For j = 1 To 9
If wojCol(j) > 0 Then
If Abs(shZ.Cells(baseRow + i - 1, wojCol(j)).Value - Round(M(i, j), 2)) > tol Then
shZ.Cells(baseRow + i - 1, wojCol(j)).Interior.Color = vbYellow: errs = errs + 1
End If
End If
Next j
Next i
' Sprawdzenie sum kolumn (wiersz sumRow)
For j = 1 To 9
Dim s As Double: s = 0
For i = 1 To 5: s = s + M(i, j): Next i
If wojCol(j) > 0 Then
If Abs(shZ.Cells(sumRow, wojCol(j)).Value - Round(s, 2)) > tol Then
shZ.Cells(sumRow, wojCol(j)).Interior.Color = vbYellow: errs = errs + 1
End If
End If
Next j
End If
' Sprawdzenie L16 = liczba unikalnych KGW z końcówką "56"
If Abs(CDbl(Val(Replace(CStr(shZ.Range("L16").Value), ",", "."))) - uniq56.Count) > 0.5 Then
shZ.Range("L16").Interior.Color = vbYellow: errs = errs + 1
End If
' Komunikat końcowy
If errs = 0 Then
MsgBox "OK", vbInformation
Else
MsgBox "Nieprawidłowości: " & errs, vbExclamation
End IfEnd Sub
Option Explicit – zmusza do deklarowania zmiennych. Bez tego „xrs” zamiast „xrs” przejdzie, ale policzy coś do śmieciowej zmiennej. Tu nie przejdzie.
ColByName – zdejmuje z barków pamiętanie numerów kolumn. Wystarczy podać fragment nagłówka, np. „Koszt”, a funkcja znajdzie właściwą kolumnę, nawet gdy ktoś zmieni kolejność.
Nz – bezpieczna konwersja do liczby. Jeśli w danych jest pusta komórka, tekst albo błąd, funkcja zwróci 0 (albo inną domyślną wartość). Dzięki temu sumy się nie wywalają.
Raport_OK – serce konsolidacji. Najpierw odnajduje arkusze „dane” i „zestawienie koszt…”. Potem ustala, gdzie są kolumny: „Numer KGW”, „Data”, „Początkowa wartość”, „Koszt”, „Rozchod”, „Końcowa wartość”. Dalej leci po wierszach danych. Z każdego numeru KGW bierze pierwsze 8 znaków jako klucz grupy, a z końcówki i początku numeru wyciąga rodzaj (52–56) i województwo (1–9). W słowniku dict1 trzyma pięć wartości dla każdej grupy: najstarszą datę oraz sumy P/K/R/Kon. W macierzy M zbiera koszty w układzie rodzaj×województwo. Na końcu sortuje klucze, czyści arkusz raportu, wpisuje wiersze wyników i wstawia tablicę 52..56 × województwa, plus sumy kolumn. Do komórki L16 wpisuje, ile unikalnych numerów kończy się na „56”.
Walidacja_Prosta – drugi biegun procesu. Niezależnie od Raport_OK jeszcze raz liczy te same sumy ze źródła do słownika i macierzy. Następnie porównuje to z tym, co jest w „zestawieniu”. Tolerancja to 0,01, więc drobne różnice wynikające z zaokrągleń nie wywołają fałszywego alarmu. Jeżeli znajdzie rozjazdy, podświetla komórki na żółto. Jeżeli w raporcie istnieje wiersz bez odpowiedniego klucza w danych, zaznacza cały blok 3..6 na czerwono. Sprawdza też tablicę rodzaj×województwo i sumy kolumn, a na końcu porównuje liczbę w L16 z policzonym zbiorem uniq56. Gdy wszystko gra wyświetla „OK”. Inaczej podaje liczbę nieprawidłowości.
Dlaczego to działa dobrze w codziennej pracy
Nie trzeba nic przepinać, gdy zmieni się układ kolumn czy nazwa arkusza – ważne, by zawierała słowo-klucz („dane”, „zestawienie”, „koszt”). Konsolidacja i walidacja są od siebie niezależne: możesz najpierw zbudować raport (Raport_OK), a potem go zweryfikować (Walidacja_Prosta). Kolory od razu prowadzą wzrok do problemów, a licznik błędów na końcu zamyka temat bez wertowania całego pliku.
Na co uważać i jak dopieścić
- Jeśli któryś nagłówek jest bardzo podobny do innego,
LookAt:=xlPartmoże złapać zły. W razie potrzeby zmień naxlWhole. - Gdyby w pliku były dodatkowe dane albo zakres danych – koniecznie poszerz wymiary macierzy
M. - Jeśli raport bywa bardzo duży, dodaj
Application.ScreenUpdating = FalseiApplication.Calculation = xlCalculationManualna start i przywracanie na końcu – przyspieszy to działanie.
