coding123456
New Member
- Joined
- Feb 11, 2025
- Messages
- 5
- Office Version
- 365
- Platform
- Windows
HI Everyone,
I have writtten a code where to split it accordingly by grouping, the vba code is as below
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
I have writtten a code where to split it accordingly by grouping, the vba code is as below
VBA Code:
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