Separate sections custom sort - numbers with text separate sections

[butch3]

I've attached two images that will help visualize what I'm trying to do. I have 4 different types of data that need to be sorted. In the 'example' image, you can see that the accounts (Col A) is all clumped together. The 'output' image shows what I would like to happen. The number of data elements will change for each spreadsheet (macro) I would run the code on. Highlighting of the two sums preferred.

The first section in 'output' is for the accounts that are only numbers. The second sections is for accounts that have letters after the first 3 digits.

A Sum is produced for a combined total of the values in the Amt Column.

Next, when the first three digits are 'Fnd'. Total is produced for this section. The numbers to the right of the Amt column is removed.

Lastly, if the Name Column is named 'Enc' the row would be placed in this section. An alternate way to code this is to evaluate whether the 5th and 6th digit is 0 if it is, the row transfers into the last section and a sum for this section is produced. The numbers to the right of the Amt column is removed.

Note, each section is sorted by the Account without any sorting into any other section.


Example:

Book1
	A	B				F	G	H
1	Acct	Name				Amt	New Amt	Difference
2	456 456					9	5	4
3	654 2F2					8	4	4
4	123 456					7	3	4
5	Fnd 203					6	2	4
6	789 987					5	0	5
7	123 001	Enc				4	1	3
8	654 456					3	6	-3
9	Fnd 101					2	7	-5
10	258 753					0	8	-8
11	789 002	Enc				1	9	-8
Sheet1

After Macro Output:

Book1
	A	B				F	G	H	I
1	Acct	Name				Amt	New Amt	Difference
2	123 456					7	3	4
3	258 753					0	8	-8
4	456 456					9	5	4
5	654 456					3	6	-3
6	789 987					5	0	5
7
8	654 2F2					8	4	4
9						32	26	6	Total
10
11	Fnd 101					2
12	Fnd 203					6
13						8			Total
14
15	123 001	Enc				4
16	789 002	Enc				1
17						5			Total
Sheet1

 

[DanteAmor]

To work on sheet1try this:

Option Explicit

Dim b As Variant, c As Variant, d As Variant, e As Variant

Sub Separate_sections()
  Dim a As Variant, sh1 As Worksheet, sh2 As Worksheet
  Dim i As Long, nb As Long, nc As Long, nd As Long, ne As Long
  Dim lr As Long, lr2 As Long
  
  Application.ScreenUpdating = False
  
  Set sh1 = Sheets("Sheet1")
  
  a = sh1.Range("A2:H" & sh1.Range("A" & Rows.Count).End(xlUp).Row).Value2
  Sh1.rows("2:" & rows.count).clearcontents
  ReDim b(1 To UBound(a), 1 To 8)
  ReDim c(1 To UBound(a), 1 To 8)
  ReDim d(1 To UBound(a), 1 To 6)
  ReDim e(1 To UBound(a), 1 To 6)
  
  For i = 1 To UBound(a)
    Select Case True
      Case a(i, 2) = "Enc"
        ne = ne + 1
        Call fillarray(a, i, e, ne, 6)
      Case Left(a(i, 1), 3) = "Fnd"
        nd = nd + 1
        Call fillarray(a, i, d, nd, 6)
      Case IsNumeric(Split(a(i, 1), " ")(1))
        nb = nb + 1
        Call fillarray(a, i, b, nb, 8) '
      Case Else
        nc = nc + 1
        Call fillarray(a, i, c, nc, 8)
    End Select
  Next
  
  Call FillSheet(sh1, 2, 2, b, nb, 8, False, "H")
  
  lr = sh1.Range("A" & Rows.Count).End(xlUp).Row + 2
  Call FillSheet(sh1, 2, lr, c, nc, 8, True, "H")
  
  lr = sh1.Range("A" & Rows.Count).End(xlUp).Row + 3
  Call FillSheet(sh1, lr, lr, d, nd, 6, True, "F")
  
  lr = sh1.Range("A" & Rows.Count).End(xlUp).Row + 3
  Call FillSheet(sh1, lr, lr, e, ne, 6, True, "F")
End Sub

Sub FillSheet(sh2 As Worksheet, ini As Long, nRow As Long, ary As Variant, _
              nx As Long, col As Long, bFormula As Boolean, cf As String)
  Dim lr2 As Long
  sh2.Range("A" & nRow).Resize(nx, col).Value = ary
  sh2.Range("A" & nRow).Resize(nx, col).sort key1:=sh2.Range("A" & nRow), order1:=xlAscending, Header:=xlNo
  If bFormula Then
    lr2 = sh2.Range("A" & Rows.Count).End(xlUp).Row + 1
    With sh2.Range("F" & lr2 & ":" & cf & lr2)
      .Formula = "=sum(F" & ini & ":F" & lr2 - 1 & ")"
      .Value = .Value
    End With
    sh2.Range("I" & lr2).Value = "Total"
  End If
End Sub

Sub fillarray(a As Variant, i As Long, arr As Variant, n As Long, m As Long)
  Dim j As Long
  For j = 1 To m
    arr(n, j) = a(i, j)
  Next
End Sub

 

[butch3]

Hey @DanteAmor . Thanks for your help!

I have a question with your code, something that I realize I need to modify.

When the macro checks to see if the account code is numeric for those non numeric Accounts it moved those accounts to the 2nd section. The original example data set didn't include the possibility that some accounts may have a letter at the end that needs to go in the first section. I'm trying to figure out your code below to make the modification but as a newbie I can't figure it out. I've included the example data and output needed below. TIA.

In the Output spreadsheet, I've highlighted some of the differences between the previous output and this one. In addition to Enc or Encumbrances, Voucher should be included in the bottom section. Also, the accounts that need to be in the second section have more digits (I don't think that's relevant though). Some of those Accounts in the first section will have text. The way to determine this is if the last digit in the account has only a letter at the end, then it goes into the first section. I also changed where the total text is located.

Also, the only Account that may not be in the dataset from time to time is Fnd. So, the macro can't error or crash if Fnd is not found, the macro still has to sort but without crating a total or if statement for that section. Please let me know if you have questions.

      Case IsNumeric(Split(a(i, 1), " ")(1))
        nb = nb + 1
        Call fillarray(a, i, b, nb, 8) '
      Case Else
        nc = nc + 1
        Call fillarray(a, i, c, nc, 8)

EXAMPLE:

Book1
	A	B				F	G	H
1	Acct	Name				Amt	New Amt	Difference
2	999 9999999					3	4	-1
3	321 12ST012924					2	5	-3
4	213 16GS016924					3	3	0
5	Fnd 203					4	1	3
6	101 4410231					5	5	0
7	413 4220460L					6	6	0
8	361 2100001	Encumbrance				7	7	0
9	413 4220460S					8	8	0
10	316 4410261					9	9	0
11	Fnd 101					1	3	-2
12	101 2100002	Voucher				2	1	1
13	101 2100001	Encumbrance				3	2	1
Sheet1

OUTPUT:

Book1
	A	B				F	G	H
1	Acct	Name				Amt	New Amt	Difference
2	101 4410231					5	5	0
3	316 4410261					9	9	0
4	413 4220460L					6	6	0
5	413 4220460S					8	8	0
6	999 9999999					3	4	-1
7
8	213 16GS016924					3	3	0
9	321 12ST012924					2	5	-3
10		Total				36	40	-4
11								Not Balanced
12
13	Fnd 101					1
14	Fnd 203					4
15		Total				5
16						Not Balanced
17
18	101 2100001	Encumbrance				3
19	361 2100001	Encumbrance				7
20	101 2100002	Voucher				2
21		Total				12
22						Not Balanced
Sheet1

Cell Formulas
Range	Formula
H2:H6, H8:H9	H2	=F2-G2
F10:G10, H10	F10	=SUM(F2:F9)
H11, F16	H11	=IF(H10=0,"Balanced","Not Balanced")
F15	F15	=SUM(F13:F14)
F21	F21	=SUM(F18:F20)
F22	F22	=IF(F10+F21=0,"Balanced","Not Balanced")

 

[DanteAmor]

Please, manually create sheet2 and try the code. I understand perfectly that you want everything on one sheet, only for testing, when you have everything well tested, you change it to a single sheet.

All your requirements are adjusted in the following code.

Option Explicit

Dim b As Variant, c As Variant, d As Variant, e As Variant

Sub Separate_sections()
  Dim a As Variant, sh1 As Worksheet, sh2 As Worksheet
  Dim i As Long, nb As Long, nc As Long, nd As Long, ne As Long
  Dim lr As Long, lr2 As Long, m
  
  Application.ScreenUpdating = False
  
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  sh2.Rows("2:" & Rows.Count).ClearContents
  a = sh1.Range("A2:H" & sh1.Range("A" & Rows.Count).End(xlUp).Row).Value2
  
  ReDim b(1 To UBound(a), 1 To 8)
  ReDim c(1 To UBound(a), 1 To 8)
  ReDim d(1 To UBound(a), 1 To 6)
  ReDim e(1 To UBound(a), 1 To 6)
  
  For i = 1 To UBound(a)
    m = Split(a(i, 1), " ")(1)
    m = Left(m, Len(m) - 1)
    Select Case True
      Case Left(a(i, 2), 3) = "Enc", Left(a(i, 2), 3) = "Vou"
        ne = ne + 1
        Call fillarray(a, i, e, ne, 6)
      Case Left(a(i, 1), 3) = "Fnd"
        nd = nd + 1
        Call fillarray(a, i, d, nd, 6)
      Case IsNumeric(m)
        nb = nb + 1
        Call fillarray(a, i, b, nb, 8) '
      Case Else
        nc = nc + 1
        Call fillarray(a, i, c, nc, 8)
    End Select
  Next
  
  If nb > 0 Then Call FillSheet(sh2, 2, 2, b, nb, 8, False, "H")
  
  lr = sh2.Range("A" & Rows.Count).End(xlUp).Row + 2
  If nc > 0 Then Call FillSheet(sh2, 2, lr, c, nc, 8, True, "H")
  
  lr = sh2.Range("A" & Rows.Count).End(xlUp).Row + 4
  If nd > 0 Then Call FillSheet(sh2, lr, lr, d, nd, 6, True, "F")
  
  lr = sh2.Range("A" & Rows.Count).End(xlUp).Row + 4
  If ne > 0 Then Call FillSheet(sh2, lr, lr, e, ne, 6, True, "F")
End Sub

Sub FillSheet(sh2 As Worksheet, ini As Long, nRow As Long, ary As Variant, _
              nx As Long, col As Long, bFormula As Boolean, cf As String)
  Dim lr2 As Long
  sh2.Range("A" & nRow).Resize(nx, col).Value = ary
  sh2.Range("A" & nRow).Resize(nx, col).sort key1:=sh2.Range("A" & nRow), order1:=xlAscending, Header:=xlNo
  If bFormula Then
    lr2 = sh2.Range("A" & Rows.Count).End(xlUp).Row + 1
    With sh2.Range("F" & lr2 & ":" & cf & lr2)
      .Formula = "=SUM(F" & ini & ":F" & lr2 - 1 & ")"
      .Value = .Value
    End With
    sh2.Range("B" & lr2).Value = "Total"
    With sh2.Range(cf & lr2)
      If .Value = 0 Then .Offset(1).Value = "Balanced" Else .Offset(1).Value = "Not Balanced"
    End With
  End If
End Sub

Sub fillarray(a As Variant, i As Long, Arr As Variant, n As Long, m As Long)
  Dim j As Long
  For j = 1 To m
    Arr(n, j) = a(i, j)
  Next
End Sub

 

[butch3]

Runs well for the most part.

The only issue I see is in the 'Output' example above, cell F22 checks whether F10 & F21 summed is equal to 0. Cell F21 should have the negative of F10 for F22 to display in Balance. The other 2 check if the sum is equal to 0 - those work right.

Thanks @DanteAmor !

An just so I know for my own reference, how easy or difficult was it to rewrite the code from what you had written originally? Thanks.

 

[DanteAmor]

cell F22 checks whether F10 & F21 summed is equal to 0

For that I add the wtot variable:

Option Explicit

Dim b As Variant, c As Variant, d As Variant, e As Variant, wtot As Double

Sub Separate_sections()
  Dim a As Variant, sh1 As Worksheet, sh2 As Worksheet
  Dim i As Long, nb As Long, nc As Long, nd As Long, ne As Long
  Dim lr As Long, lr2 As Long, m
  
  Application.ScreenUpdating = False
  
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  sh2.Rows("2:" & Rows.Count).ClearContents
  a = sh1.Range("A2:H" & sh1.Range("A" & Rows.Count).End(xlUp).Row).Value2
  
  ReDim b(1 To UBound(a), 1 To 8)
  ReDim c(1 To UBound(a), 1 To 8)
  ReDim d(1 To UBound(a), 1 To 6)
  ReDim e(1 To UBound(a), 1 To 6)
  
  For i = 1 To UBound(a)
    m = Split(a(i, 1), " ")(1)
    m = Left(m, Len(m) - 1)
    Select Case True
      Case Left(a(i, 2), 3) = "Enc", Left(a(i, 2), 3) = "Vou"
        ne = ne + 1
        Call fillarray(a, i, e, ne, 6)
      Case Left(a(i, 1), 3) = "Fnd"
        nd = nd + 1
        Call fillarray(a, i, d, nd, 6)
      Case IsNumeric(m)
        nb = nb + 1
        Call fillarray(a, i, b, nb, 8) '
      Case Else
        nc = nc + 1
        Call fillarray(a, i, c, nc, 8)
    End Select
  Next
  
  If nb > 0 Then Call FillSheet(sh2, 2, 2, b, nb, 8, False, "H", 0)
  
  lr = sh2.Range("A" & Rows.Count).End(xlUp).Row + 2
  If nc > 0 Then Call FillSheet(sh2, 2, lr, c, nc, 8, True, "H", 1)
  
  lr = sh2.Range("A" & Rows.Count).End(xlUp).Row + 4
  If nd > 0 Then Call FillSheet(sh2, lr, lr, d, nd, 6, True, "F", 0)
  
  lr = sh2.Range("A" & Rows.Count).End(xlUp).Row + 4
  If ne > 0 Then Call FillSheet(sh2, lr, lr, e, ne, 6, True, "F", 2)
End Sub

Sub FillSheet(sh2 As Worksheet, ini As Long, nRow As Long, ary As Variant, _
              nx As Long, col As Long, bFormula As Boolean, cf As String, x As Long)
  Dim lr2 As Long
  sh2.Range("A" & nRow).Resize(nx, col).Value = ary
  sh2.Range("A" & nRow).Resize(nx, col).sort key1:=sh2.Range("A" & nRow), order1:=xlAscending, Header:=xlNo
  If bFormula Then
    lr2 = sh2.Range("A" & Rows.Count).End(xlUp).Row + 1
    With sh2.Range("F" & lr2 & ":" & cf & lr2)
      .Formula = "=SUM(F" & ini & ":F" & lr2 - 1 & ")"
      .Value = .Value
      If x = 1 Then wtot = sh2.Range("F" & lr2).Value
    End With
    sh2.Range("B" & lr2).Value = "Total"
    With sh2.Range(cf & lr2)
      Select Case x
        Case 0, 1
          If .Value = 0 Then .Offset(1).Value = "Balanced" Else .Offset(1).Value = "Not Balanced"
        Case Else
          If wtot + .Value = 0 Then .Offset(1).Value = "Balanced" Else .Offset(1).Value = "Not Balanced"
      End Select
    End With
  End If
End Sub

Sub fillarray(a As Variant, i As Long, Arr As Variant, n As Long, m As Long)
  Dim j As Long
  For j = 1 To m
    Arr(n, j) = a(i, j)
  Next
End Sub

An just so I know for my own reference, how easy or difficult was it to rewrite the code from what you had written originally?

A bit complicated by the different exceptions.

 

[butch3]

Thanks a million @DanteAmor . The macro works.

Question: if from time to time, I need to change the term 'vou' or even 'enc' to something else, like a 7 letter work such as 'Payable', what code would I change to make it so that the term Payable in Column B would be in the last section?

This is the part of code I'd have to change right? Nothing else.

 For i = 1 To UBound(a)
    m = Split(a(i, 1), " ")(1)
    m = Left(m, Len(m) - 1)
    Select Case True
      Case Left(a(i, 2), 3) = "Enc", Left(a(i, 2), 3) = "Vou"
        ne = ne + 1
        Call fillarray(a, i, e, ne, 6)

 

[DanteAmor]

Yes it is.
It would be something like this:

Case Left(a(i, 2), 3) = "Enc", Left(a(i, 2), 3) = "Vou",  Left(a(i, 2), 7) = "Payable "

 

[butch3]

Okay. So the 'Example' dataset works and doesn't have this issue, but when I try this macro on my actual dataset there's an error that I didn't notice before.

I was wondering why my actual data wasn't reconciling and as I was debugging, I realized that the first line from Sheet1 is not being displayed on Sheet2. Maybe it is but something else is happening.

 

[butch3]

Okay. So the 'Example' dataset works and doesn't have this issue, but when I try this macro on my actual dataset there's an error that I didn't notice before.

I was wondering why my actual data wasn't reconciling and as I was debugging, I realized that the first line from Sheet1 is not being displayed on Sheet2. Maybe it is but something else is happening.

View attachment 5896

Actually, this is not the issue. I've been running the function in silos (subroutines) to determine the issue.

For some reason,

If wtot + .Value = 0 Then .Offset(1).Value = "Balanced" Else .Offset(1).Value = "Not Balanced"

is not properly recognizing that the two numbers match. I've checked the data and they match.

 

[butch3]

I'm going to debug some more in the morning so I can fix or give a more accurate assessment of the issue.