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]

Try this

Your data on Sheet1, results on Sheet2

Put everything in a module and run the "Separate_sections" macro

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")
  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)
    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(sh2, 2, 2, b, nb, 8, False, "H")
  
  lr = sh2.Range("A" & Rows.Count).End(xlUp).Row + 2
  Call FillSheet(sh2, 2, lr, c, nc, 8, True, "H")
  
  lr = sh2.Range("A" & Rows.Count).End(xlUp).Row + 3
  Call FillSheet(sh2, lr, lr, d, nd, 6, True, "F")
  
  lr = sh2.Range("A" & Rows.Count).End(xlUp).Row + 3
  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("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]

If Sheet2 doesn't exist in the document, how can we code it so that it will open a new sheet titled Sheet2 so the macro can work?

I can see how separate sheets can help with the data sort but I really only want this one sheet. Can we code the deletion of the Sheet1 with the original data once we're done?

Once Sheet1 is deleted, can we rename Sheet2 to Sheet1? (with code)

 

[DanteAmor]

Once Sheet1 is deleted, can we rename Sheet2 to Sheet1? (with code)

Of course, I can do that, but first you could try the macro as it is.
I understand that you want everything on one sheet, but for the purpose of the test, you can create the sheet2 and run the macro.
Review the results and comment.

 

[butch3]

I wrote some code to add the sheet and delete the previous one.

I ran your code and I'm getting a Runtime Error 1004. There is some other code in the module that I'm using with my macro but the variable seem to be different.

 

[butch3]

okay, I just moved the nx As Long line up and it worked.

With my delete sheet code, it's asking me to confirm I want to delete it. Can I bypass that?

 

[butch3]

Not resolved. I'm still getting the Runtime Error 1004.

 

[DanteAmor]

You could try the macro without modifying it. only for testing purposes, then I help you with the creation of the sheet, that is very simple, the complicated thing is to separate the data. Create sheet2 manually and test.

 

[butch3]

I figured out what the issue was. Your coding was fine. The dataset I was working with didn't have exactly the 'Enc' term. Solved.

I just used Application.DisplayAlerts = False so that I don't get sheet deletion notification.

Thanks for your coding help!!!

 

[DanteAmor]

Im glad to help you, thanks for the feedback.