VBA || Transpose unique values and Sums - vba

Question

I'm currently trying to make a map that transposes unique values from a column and populate this new list with some parameters from another table,
the result on this map should be the following
I've already have the code for the unique values as follows:
Dim d As Object
Dim c As Variant
Dim i As Long
Dim lr As Long
Set d = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, 9).End(xlUp).Row
c = Range("B2:B" & lr)
For i = 1 To UBound(c, 1)
d(c(i, 1)) = 1
Next i
Range("AK2").Resize(d.Count) = Application.Transpose(d.keys)
Although for filling the amounts on the columns Base and VAT I'm having some issues trying to think on the formula, basically for "Base" the value should be the total by Document Nr of the accounts starting with 6*,7* which are a result of Dr - Cr.
I know it may sound a bit confusing, but if anyone could please help me I would be much appreciated.

Answer 1

Using #RonRosenfeld formula from comments, following might be helpful:
Sub Demo()
Dim lastRow As Long, lastCol As Long, currLR As Long
Dim rng As Range, rngWH As Range
Dim srcSht As Worksheet
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set srcSht = Sheets("Sheet1") 'set data sheet here
With srcSht
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row 'last row with data in sheet
Set rng = .Range("A1:A" & lastRow) 'range for filter
Set rngWH = .Range("A2:A" & lastRow) 'range for formulas
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column + 2 'column to display data
rng.AdvancedFilter Action:=xlFilterCopy, copytoRange:=.Cells(1, lastCol), unique:=True
currLR = .Cells(.Rows.Count, lastCol).End(xlUp).Row 'unique nr. doc count
lastCol = lastCol + 1
'formula for Base
.Cells(1, lastCol).Value = "Base"
.Range(.Cells(2, lastCol), .Cells(currLR, lastCol)).Formula = _
"=SUMPRODUCT((" & .Cells(2, lastCol - 1).Address(False, False) & "=" & rngWH.Address & ")*(LEFT(" & rngWH.Offset(, 1).Address & ")={""6"",""7""})*(" & rngWH.Offset(, 2).Address & "))"
'formula for Vat
.Cells(1, lastCol + 1).Value = "VAT"
'enter formula here for VAT
'formula for Total
.Cells(1, lastCol + 2).Value = "Total"
.Range(.Cells(2, lastCol + 2), .Cells(currLR, lastCol + 2)).Formula = _
"=SUMIF(" & rngWH.Address & "," & .Cells(2, lastCol - 1).Address(False, False) & "," & rngWH.Offset(, 3).Address & ")"
.Range(.Cells(2, lastCol), .Cells(currLR, lastCol + 2)).Value = .Range(.Cells(2, lastCol), .Cells(currLR, lastCol + 2)).Value
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Answer 2

For a "pure" VBA solution, I would
create a user defined object which as the properties of Nr.Doc, Acct, VAT, Base and Total.
Base, as you wrote, we detect by checking the first digit of the account
VAT will be any amount in the Dr column that does not start with 6 or 7
Total will be the values in the Cr column.
If your rules are different, by setting things up like this, they can be easily changed, as the code is almost self-documenting.
For the UDO, we enter a class module and rename it cDoc.
Also, I chose to use early-binding so we set a reference to Microsoft Scripting Runtime. If you want to change it to late-binding as you do in your posted code, feel free to do that. It can be easier if you are distributing the file; but I prefer to have the Intellisense available when I am coding.
Class Module
Option Explicit
'Rename this module "cDoc"
Private pDocNum As String
Private pAcct As String
Private pBase As Currency
Private pVAT As Currency
Private pTotal As Currency
Public Property Get Acct() As String
Acct = pAcct
End Property
Public Property Let Acct(Value As String)
pAcct = Value
End Property
Public Property Get Base() As Currency
Base = pBase
End Property
Public Property Let Base(Value As Currency)
pBase = Value
End Property
Public Property Get VAT() As Currency
VAT = pVAT
End Property
Public Property Let VAT(Value As Currency)
pVAT = Value
End Property
Public Property Get Total() As Currency
Total = pTotal
End Property
Public Property Let Total(Value As Currency)
pTotal = Value
End Property
Public Property Get DocNum() As String
DocNum = pDocNum
End Property
Public Property Let DocNum(Value As String)
pDocNum = Value
End Property
Regular Module
Option Explicit
'Set Reference to Microsoft Scripting Runtime
' you can change this to late binding if everything works
Sub ReOrganizeTable()
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim vSrc As Variant, vRes As Variant
Dim dDoc As Dictionary, cD As cDoc
Dim I As Long
Dim V As Variant
'Set source and results worksheets
'Read source data into variant array
Set wsSrc = Worksheets("sheet1")
With wsSrc
vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=4)
End With
On Error Resume Next
Set wsRes = Worksheets("Results")
Select Case Err.Number
Case 9
Set wsRes = Worksheets.Add(after:=wsSrc)
wsRes.Name = "Results"
Case Is <> 0
Debug.Print Err.Number, Err.Description
Stop
End Select
On Error GoTo 0
Set rRes = wsRes.Cells(1, 1)
'Gather and organize the data
Set dDoc = New Dictionary
For I = 2 To UBound(vSrc, 1)
Set cD = New cDoc
With cD
.DocNum = vSrc(I, 1)
.Acct = CStr(vSrc(I, 2))
Select Case Left(.Acct, 1)
Case 6, 7
.Base = vSrc(I, 3)
Case Else
.VAT = vSrc(I, 3)
End Select
.Total = vSrc(I, 4)
If Not dDoc.Exists(.DocNum) Then
dDoc.Add Key:=.DocNum, Item:=cD
Else
dDoc(.DocNum).Base = dDoc(.DocNum).Base + .Base
dDoc(.DocNum).VAT = dDoc(.DocNum).VAT + .VAT
dDoc(.DocNum).Total = dDoc(.DocNum).Total + .Total
End If
End With
Next I
'Size results array
ReDim vRes(0 To dDoc.Count, 1 To 4)
'Headers
vRes(0, 1) = "Nr Doc"
vRes(0, 2) = "Base"
vRes(0, 3) = "VAT"
vRes(0, 4) = "Total"
'Populate the data area
I = 0
For Each V In dDoc.Keys
I = I + 1
Set cD = dDoc(V)
With cD
vRes(I, 1) = .DocNum
vRes(I, 2) = .Base
vRes(I, 3) = .VAT
vRes(I, 4) = .Total
End With
Next V
'write and format the results
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.Value = vRes
With .Rows(1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
.EntireColumn.AutoFit
End With
End Sub
Results
Using your original posted data