VBA code for new workbook extraction with data grouping

coding123456

New Member
Joined
Feb 11, 2025
Messages
5
Office Version
  1. 365
Platform
  1. Windows
HI Everyone,
I have writtten a code where to split it accordingly by grouping, the vba code is as below
VBA Code:
Sub SplitDataByGroups()
Dim ws As Worksheet
Dim wb As Workbook, newWb As Workbook
Dim lastRow As Long, lastCol As Long
Dim savePath As String
Dim i As Long, groupStart As Long, lastLRow As Long
Dim copiedRange As Range
Dim fileCounter As Integer
Dim isLastGroup As Boolean

' Set the worksheet
Set wb = ThisWorkbook
Set ws = wb.Sheets("Auto BL Journal")

' Find last row and ensure column BD is captured
lastRow = ws.Cells(ws.Rows.Count, 5).End(xlUp).Row
lastCol = 56 ' Column BD

' Get save path
savePath = wb.Path & "\"

' Initialize file counter
fileCounter = 1

' Identify H & L group based on empty row separator
groupStart = 4
lastLRow = 4
isLastGroup = False

For i = 4 To lastRow + 1 ' Extend loop to catch last empty row
If ws.Cells(i, 1).Value = "H" Then
groupStart = i ' Mark start of a new group
lastLRow = i ' Reset last L row
ElseIf ws.Cells(i, 1).Value = "L" Then
lastLRow = i ' Extend group to include all L rows
End If

' Detect last group and force capture if at the last row
If (ws.Cells(i, 1).Value = "" Or i = lastRow + 1) And lastLRow >= groupStart Then
' Ensure all L rows are included, even at the last dataset group
While lastLRow < lastRow And ws.Cells(lastLRow + 1, 1).Value = "L"
lastLRow = lastLRow + 1
Wend

' If the last row has L rows, ensure they are included
If i = lastRow + 1 And ws.Cells(lastRow, 1).Value = "L" Then
lastLRow = lastRow
End If

' Create new workbook
Set newWb = Workbooks.Add

' Copy headers (Top 3 rows)
ws.Rows("1:3").Copy newWb.Sheets(1).Rows("1:3")

' Copy the detected group including all L rows
Set copiedRange = ws.Range(ws.Cells(groupStart, 1), ws.Cells(lastLRow, lastCol))
If Application.WorksheetFunction.CountA(copiedRange) > 0 Then
copiedRange.Copy
newWb.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End If

' Format Column N as Date, Column B to two decimal points, and Column U to match expected format
newWb.Sheets(1).Columns("N").NumberFormat = "mm/dd/yyyy"
newWb.Sheets(1).Columns("B").NumberFormat = "0.00"
newWb.Sheets(1).Columns("U").NumberFormat = "#,##0.00"

' Rename sheet
newWb.Sheets(1).Name = "Auto BL Journal"

' Save new workbook
If Application.WorksheetFunction.CountA(newWb.Sheets(1).UsedRange) > 0 Then
newWb.SaveAs savePath & "Variable Rent Journal_Part" & fileCounter & ".xlsx", FileFormat:=xlOpenXMLWorkbook
fileCounter = fileCounter + 1
End If

newWb.Close False

' Reset group start and last L row
groupStart = i + 1
lastLRow = i + 1
isLastGroup = False
End If
Next i

' Cleanup
MsgBox "Files successfully created in " & savePath, vbInformation, "Process Completed"

End Sub

My last data set to be extracted out to a new workbook is as below rows. the vba code able to create the right split of a new workbook, however for the last data set of the group it fails too. as seen below the screenshot attached. it only able to grab 1 L line. the last few lines of the data set were unable to to pull out as a groping for the new workbook. PLease help
 

Attachments

  • 2025-02-19_19-38-59 - last data set grouping rows.png
    2025-02-19_19-38-59 - last data set grouping rows.png
    1.5 KB · Views: 3
  • 2025-02-19_19-41-28 - the last workbook extracted.png
    2025-02-19_19-41-28 - the last workbook extracted.png
    2.8 KB · Views: 3

Forum statistics

Threads
1,226,795
Messages
6,193,045
Members
453,772
Latest member
aastupin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top