Macro to change way of showing data by transporting for each account name

[Omar M]

Hello
in RESULT sheet there is no any data, but what I want making report based on sheet1
it should populate accounts names in column B by brings from row1 from column G to last column( every time add new account name so will insert new columns)
as to column C,D for DEBIT,CREDIT will merge for each account name in SHEET1 and the BALANCE column will subtract DEBIT from CREDIT.
I would macro to deal about 7000 rows for SHEET1 when brings data to make macro really fast when brings data.

ACCOUNTS DAILY.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X
1	DATE	CONSTRAIN NO	DESCRIPTION	BALANCING CASE	TOTAL		BANK		SAFE		PURCHASE		SELLING		CAPITAL		PURCHASE RETURNING		SELLING RETURNING		RECEIVABLE		CREDITOR
2					DEBIT	CREDIT	DEBIT	CREDIT	DEBIT	CREDIT	DEBIT	CREDIT	DEBIT	CREDIT	DEBIT	CREDIT	DEBIT	CREDIT	DEBIT	CREDIT	DEBIT	CREDIT	DEBIT	CREDIT
3	11/08/2024	1	DEPOSIT CAPITAL	BALANCED	2,000.00	2,000.00			2,000.00							2,000.00
4	11/08/2024	2	BUYING GOODS	BALANCED	3,500.00	3,500.00		1,500.00		2,000.00	3,500.00
5	11/08/2024	3	SELLING GOODS	NOT BALANCED	10,000.00	15,000.00	10,000.00							15,000.00
6	11/08/2024	4	SELLING GOODS	BALANCED	3,000.00	3,000.00			3,000.00					3,000.00
7	11/08/2024	5	INCREASE CAPITAL	BALANCED	15,000.00	15,000.00			15,000.00							15000
8	12/08/2024	6	DECREASE CAPITAL	BALANCED	3,000.00	3,000.00				3,000.00					3,000.00
sheet1

should be like this

ACCOUNTS DAILY.xlsm
	A	B	C	D	E
1	ITEM	DEBIT	DEBIT	CREDIT	BALANCE
2	1	BANK	10,000.00	1,500.00	8,500.00
3	2	SAFE	20,000.00	5,000.00	15,000.00
4	3	PURCHASE	3,500.00	0.00	3,500.00
5	4	SELLING	0.00	18,000.00	-18,000.00
6	5	CAPITAL	3,000.00	17,000.00	-14,000.00
7	6	PURCHASE RETURNING	0.00	0.00	0.00
8	7	SELLING RETURNING	0.00	0.00	0.00
9	8	RECEIVABLE	0.00	0.00	0.00
10	9	CREDITOR	0.00	0.00	0.00
RESULT

Cell Formulas
Range	Formula
E2:E10	E2	=C2-D2

I hope finding assistance as DanteAmore did it in earlier .

 

[Peter_SSs]

Do you need a macro? Could you do it with formulas something like this?

Omar M.xlsm
	A	B	C	D	E
1	ITEM	DEBIT	DEBIT	CREDIT	BALANCE
2	1	BANK	10,000.00	1,500.00	8,500.00
3	2	SAFE	20,000.00	5,000.00	15,000.00
4	3	PURCHASE	3,500.00	0.00	3,500.00
5	4	SELLING	0.00	18,000.00	-18,000.00
6	5	CAPITAL	3,000.00	17,000.00	-14,000.00
7	6	PURCHASE RETURNING	0.00	0.00	0.00
8	7	SELLING RETURNING	0.00	0.00	0.00
9	8	RECEIVABLE	0.00	0.00	0.00
10	9	CREDITOR	0.00	0.00	0.00
11
12
RESULT

Cell Formulas
Range	Formula
A2:A12	A2	=IF(B2="","",COUNTA(B$2:B2))
B2:B12	B2	=INDEX(Sheet1!G$1:AZ$1,ROWS(B$2:B2)*2-1)&""
C2:C12	C2	=IF(A2="","",SUMPRODUCT((Sheet1!G$1:AZ$1=$B2)*(Sheet1!G$2:AZ$2=C$1)*Sheet1!G$3:AZ$10000))
D2:D12	D2	=IF(A2="","",SUMPRODUCT((Sheet1!G$1:AY$1=$B2)*(Sheet1!H$2:AZ$2=D$1)*Sheet1!H$3:AZ$10000))
E2:E12	E2	=IF(A2="","",C2-D2)

 

[Alex Blakenburg]

If you decide you do need a macro see if this works for you.
It assumes that the Sheet RESULT already exists and already has the heading.

Sub ReformatData()

    Dim wsSrc As Worksheet, wsResult As Worksheet
    Dim rngSrc As Range, arrSrc As Variant
    Dim arrResult As Variant, itemResult As Long
    Dim rngResult As Range
    Dim lrResult As Long
    Dim i As Long, j As Long
    
    Set wsSrc = Worksheets("Sheet1")
    Set rngSrc = wsSrc.Range("A1").CurrentRegion
    arrSrc = rngSrc.Value
    
    Set wsResult = Worksheets("Result")
    Set rngResult = wsResult.Range("A1").CurrentRegion
    rngResult.Offset(1).ClearContents
    
    Dim dictSrc As Object, dictKey As String
    
    Set dictSrc = CreateObject("Scripting.dictionary")
    dictSrc.CompareMode = vbTextCompare
    
    ' Load details range into Dictionary
    For j = Columns("G").Column To UBound(arrSrc, 2) Step 2
        If arrSrc(1, j) <> "" Then
            dictKey = arrSrc(1, j)
            If Not dictSrc.exists(dictKey) Then
                itemResult = itemResult + 1
                dictSrc(dictKey) = itemResult
                arrSrc(1, j + 1) = arrSrc(1, j)
            End If
        End If
    Next j
    
    ReDim arrResult(1 To dictSrc.Count, 1 To 4)
    
    For i = 3 To UBound(arrSrc)
        For j = Columns("G").Column To UBound(arrSrc, 2) Step 2
            itemResult = dictSrc(arrSrc(1, j))
            arrResult(itemResult, 1) = itemResult
            arrResult(itemResult, 2) = arrSrc(1, j)
            arrResult(itemResult, 3) = arrResult(itemResult, 3) + arrSrc(i, j)
            arrResult(itemResult, 4) = arrResult(itemResult, 4) + arrSrc(i, j + 1)
        Next j
    Next i
    
    rngResult.Offset(1).Resize(UBound(arrResult), UBound(arrResult, 2)).Value = arrResult
    rngResult.Offset(1, 4).Resize(UBound(arrResult), 1).FormulaR1C1 = "=RC[-2]-RC[-1]"

End Sub

 

[Omar M]

Thanks Peter .
indeed I search for macro .

 

[Omar M]

Thanks Alex.
not really sure why shows error subscript out of range in this line !

arrResult(itemResult, 4) = arrResult(itemResult, 4) + arrSrc(i, j + 1)

by the way I made sure sheets names in the workbook with your code.

 

[Alex Blakenburg]

What is the value of i & j & itemResult when it errors out ?

If it helps copy this into the immediate window and hit enter.

? i,j,itemResult

 

[Omar M]

into the immediate window

doesn't show anything in this window, are you sure? !

 

[Alex Blakenburg]

1) The code needs to have errored out and you hit the debug button.
2) Copy what I had including the "?" into the immediate window (Ctrl+G if its not visible) then hit enter.

I am loging off for the night and it is likely to be a data issue, so if the above doesn't help you find the issue please share a copy of your workbook via a sharing platform such as dropbox, google drive etc and make sure the workbook (if you've trimmed it down) still has the issue and that it is made available to anyone with the link.

 

[Omar M]

do you mean like this

and running the code?
if it's so doesn't show anything.

 

[Alex Blakenburg]

My guess is that you have an additional column that is detected by CurrentRegion.

Try replacing:

    For i = 3 To UBound(arrSrc)
        For j = Columns("G").Column To UBound(arrSrc, 2) Step 2
            itemResult = dictSrc(arrSrc(1, j))
            arrResult(itemResult, 1) = itemResult
            arrResult(itemResult, 2) = arrSrc(1, j)
            arrResult(itemResult, 3) = arrResult(itemResult, 3) + arrSrc(i, j)
            arrResult(itemResult, 4) = arrResult(itemResult, 4) + arrSrc(i, j + 1)
        Next j
    Next i

With this:

    For i = 3 To UBound(arrSrc)
        For j = Columns("G").Column To UBound(arrSrc, 2)
        
        If UCase(arrSrc(2, j)) = "DEBIT" Or UCase(arrSrc(2, j)) = "CREDIT" Then
            itemResult = dictSrc(arrSrc(1, j))
            arrResult(itemResult, 1) = itemResult
            arrResult(itemResult, 2) = arrSrc(1, j)
            
            If UCase(arrSrc(2, j)) = "DEBIT" Then
                arrResult(itemResult, 3) = arrResult(itemResult, 3) + arrSrc(i, j)
            Else
                 arrResult(itemResult, 4) = arrResult(itemResult, 4) + arrSrc(i, j)
            End If
        End If
        Next j
    Next i