split & delete characters into multiple sheets based on helper column

[Abdo]

Hello
I want to split SH1 into multiple sheets based on column B using helper column(G) to delete some characters .
after split data should make header name BALANCE and if the amount is credit or debit then should under BALANCE header
the the unique ID whether in helper column (G) or in column (B) will be 20 items and could be 4000 rows for SH1 sheet
and should update every sheet has already divided based on SH1 sheet and should rename sheets based on column G with considering I will add more items based on column B.
example:

sp.xlsm
	A	B	C	D	E	F	G
1	DATE	ACCOUNT REF	DEBIT	CREDIT
2	01/04/2023	PUR PURCHASE INV 000011		20,000.00			PUR PURCHASE
3	02/04/2023	PUR PURCHASE INV 000012		20,000.00			CASH PP
4	03/04/2023	PUR PURCHASE INV 000013		20,000.00			CASH SS
5	04/04/2023	PUR PURCHASE INV 000014		20,000.00			PAID PUR PURCHASE
6	05/04/2023	PUR PURCHASE INV 000015		20,000.00
7	06/04/2023	CASH PP 9000		1,000.00
8	07/04/2023	CASH SS 9001	2,000.00
9	08/04/2023	CASH PP 9002		1,200.00
10	09/04/2023	CASH SS 9003	1,200.00
11	10/04/2023	CASH SS 9004	1,300.00
12	11/04/2023	CASH SS 9005	1,400.00
13	12/04/2023	PAID PUR PURCHASE INV 000020		1,000.00
14	13/04/2023	PAID PUR PURCHASE INV 000021		2,000.00
15	14/04/2023	PAID PUR PURCHASE INV 000022		1,200.00
16	15/04/2023	PUR PURCHASE INV 000023		1,200.00
17	16/04/2023	PUR PURCHASE INV 000024		1,300.00
18	17/04/2023	PUR PURCHASE INV 000025		2,000.00
sh1

results

sp.xlsm
	A	B	C
1	DATE	ACCOUNT REF	BALANCE
2	12/04/2023	PAID PUR PURCHASE	1,000.00
3	13/04/2023	PAID PUR PURCHASE	2,000.00
4	14/04/2023	PAID PUR PURCHASE	1,200.00
PAID PUR PURCHASE

sp.xlsm
	A	B	C
1	DATE	ACCOUNT REF	BALANCE
2	06/04/2023	CASH PP	1,000.00
3	08/04/2023	CASH PP	1,200.00
CASH PP

sp.xlsm
	A	B	C
1	DATE	ACCOUNT REF	BALANCE
2	07/04/2023	CASH SS	2,000.00
3	09/04/2023	CASH SS	1,200.00
4	10/04/2023	CASH SS	1,300.00
5	11/04/2023	CASH SS	1,400.00
CASH SS

sp.xlsm
	A	B	C
1	DATE	ACCOUNT REF	BALANCE
2	01/04/2023	PUR PURCHASE	20,000.00
3	02/04/2023	PUR PURCHASE	20,000.00
4	03/04/2023	PUR PURCHASE	20,000.00
5	04/04/2023	PUR PURCHASE	20,000.00
6	05/04/2023	PUR PURCHASE	20,000.00
7	15/04/2023	PUR PURCHASE	1,200.00
8	16/04/2023	PUR PURCHASE	1,300.00
9	17/04/2023	PUR PURCHASE	2,000.00
PUR PURCHASE

 

[DanteAmor]

Hi @Abdo

I have a couple of doubts:
1. If the destination sheet already exists, you must put the data after the last record with data, or you must delete the data and put only the new one starting in cell A2.
2. Are all ACCOUNT REFs unique? If there are duplicates, they must be accumulated, how?

--------------
I hope to hear from you soon.
Respectfully
Dante Amor
--------------

 

[Abdo]

Hi Dante,

r you must delete the data and put only the new one starting in cell A2.

yes ,
I don't want to repeat the same data under last record has already copied.

2. Are all ACCOUNT REFs unique? If there are duplicates, they must be accumulated, how?

I'm not sure if I understand correctly ,
do you mean should merge like this "?
example picture 2
If you mean to merge this

sp
	A	B	C
1	ITEM	ACCOUNT REF	BALANCE
2	1	PAID PUR PURCHASE	4,200.00
PAID PUR PURCHASE

I don't mind , if you mean another thing, please just comment what do you think .

 

[DanteAmor]

I get it.

Try this:

Sub Split_ACCOUNT_REF()
  Dim sh1 As Worksheet
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long, k As Long, m As Long
  Dim newSh As String
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  Set sh1 = Sheets("sh1")
  a = sh1.Range("A2:D" & sh1.Range("B" & Rows.Count).End(3).Row).Value
  c = sh1.Range("G2:G" & sh1.Range("G" & Rows.Count).End(3).Row).Value
 
  For i = 1 To UBound(c, 1)
    newSh = c(i, 1)
    On Error Resume Next: Sheets(newSh).Delete: On Error GoTo 0
    Sheets.Add(, Sheets(Sheets.Count)).Name = newSh
    ReDim b(1 To UBound(a, 1), 1 To 3)
    m = 0
   
    For k = 1 To UBound(a, 1)
      If Left(a(k, 2), Len(newSh)) = newSh Then
        m = m + 1
        b(m, 1) = a(k, 1)
        b(m, 2) = newSh
        b(m, 3) = IIf(a(k, 3) <> "", a(k, 3), a(k, 4))
      End If
    Next
   
    With Sheets(newSh)
      sh1.Range("A1:C1").Copy .Range("A1")
      .Range("C1").Value = "BALANCE"
      .Range("A2").Resize(UBound(b, 1), 3).Value = b
    End With
   
  Next
 
  sh1.Select
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

 

[Abdo]

great!
I need fixing some things :
1- I want creating borders into cells for divided sheets as are existed in SH1 when split data .
2- should also create formatting of numbers in column C,D like this #,##0.00 for divided sheets
3- it's your choice as you like , may you merge as in picture in post#2,please?
thanks

 

[DanteAmor]

1- I want creating borders into cells for divided sheets as are existed in SH1 when split data .
2- should also create formatting of numbers in column C,D like this #,##0.00 for divided sheets

Try:

Sub Split_ACCOUNT_REF()
  Dim sh1 As Worksheet
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long, k As Long, m As Long
  Dim newSh As String
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set sh1 = Sheets("sh1")
  a = sh1.Range("A2:D" & sh1.Range("B" & Rows.Count).End(3).Row).Value
  c = sh1.Range("G2:G" & sh1.Range("G" & Rows.Count).End(3).Row).Value
  
  For i = 1 To UBound(c, 1)
    newSh = c(i, 1)
    ReDim b(1 To UBound(a, 1), 1 To 3)
    m = 0
    
    For k = 1 To UBound(a, 1)
      If Left(a(k, 2), Len(newSh)) = newSh Then
        m = m + 1
        b(m, 1) = a(k, 1)
        b(m, 2) = newSh
        b(m, 3) = IIf(a(k, 3) <> "", a(k, 3), a(k, 4))
      End If
    Next
    
    If m > 0 Then
      On Error Resume Next: Sheets(newSh).Delete: On Error GoTo 0
      Sheets.Add(, Sheets(Sheets.Count)).Name = newSh
      
      With Sheets(newSh)
        sh1.Range("A1:C1").Copy .Range("A1")
        .Range("C1").Value = "BALANCE"
        .Range("A2").Resize(m, 3).Value = b
        .Range("A1").Resize(m + 1, 3).Borders.LineStyle = xlContinuous
        .Range("A:C").EntireColumn.AutoFit
        .Range("C:C").NumberFormat = "#,##0.00"
      End With
    End If
    
  Next
  
  sh1.Select
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

 

[Abdo]

thank you so much .