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 .

 

[Omar M]

change the error to this line

arrResult(itemResult, 1) = itemResult

 

[Alex Blakenburg]

Please provide a copy of the workbook as previously requested.

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]

here is file.
Dropbox

 

[Alex Blakenburg]

I would never have guessed that without seeing the file.
Based on your original data, I am expecting a Unique Transaction Type in row 1 with a Debit and Credit column associated with it in row 2.
What is the code supposed to do with all the columns from Y to CG ?

 

[Omar M]

OMG!
sorry for this is error !
shouldn't repeat the same account name, should be different account name.
ok the code works greatly .
may I ask you for new requirement please?
Can you modify code by ignoring accounts names contains empty cells or zero for columns DEBIT,CREDIT from showing in RESULT sheet, please?

 

[Alex Blakenburg]

Ok see how you go with this:
I have modified it so, if you have repeating Transaction types is should consolidate them and added an additional loop that will filter out from the output if both Debit and Credit are 0

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("A2").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)
        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
        Else
            arrSrc(1, j) = arrSrc(1, j - 1)
        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)
        
        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
    
    Dim arrResultFiltered As Variant, irow As Long
    ReDim arrResultFiltered(1 To UBound(arrResult), 1 To UBound(arrResult, 2))
    
    For i = 1 To UBound(arrResult)
        If arrResult(i, 3) <> 0 Or arrResult(i, 4) <> 0 Then
            irow = irow + 1
            For j = 1 To UBound(arrResult, 2)
                arrResultFiltered(irow, j) = arrResult(i, j)
            Next j
        End If
    Next i
    
    rngResult.Offset(1).Resize(irow, UBound(arrResultFiltered, 2)).Value = arrResultFiltered
    rngResult.Offset(1, 4).Resize(irow, 1).FormulaR1C1 = "=RC[-2]-RC[-1]"

End Sub

 

[Omar M]

thanks Alex again
but still shows accounts names don't contain value for debit,credit !

 

[Alex Blakenburg]

We are in different timezones. If you can share the workbook that has the issue with the code it's using I can have a look on the morning.

 

[Omar M]

based on my attachment works perfectly.
many thanks Alex.

 

[Alex Blakenburg]

No problem. Glad I could help.