hi
this is as far as i get with research on the forum and copying/amending codes already used o the site.
it divides my master sheet into partcipants/clients
but i need to further tweak this
each book needs to be divided by tabs based on payment month in column e and label tab as per month
also this macro doesnt update, if there is already a book it crashes and wont let
i need to run this macro to keep updating the books about every week and payments can be added to all months
also is there a way to automatically divide based on column B Row 2, instead of the input boxes?
can anyone help
this is as far as i get with research on the forum and copying/amending codes already used o the site.
it divides my master sheet into partcipants/clients
but i need to further tweak this
each book needs to be divided by tabs based on payment month in column e and label tab as per month
also this macro doesnt update, if there is already a book it crashes and wont let
i need to run this macro to keep updating the books about every week and payments can be added to all months
also is there a way to automatically divide based on column B Row 2, instead of the input boxes?
can anyone help
VBA Code:
Sub SplitToParticipants()
Dim Master As Worksheet
Dim iRow As Long
Dim iCol As Long
Dim iFirstRow As Long
Dim iTotalRows As Long
Dim iStartRow As Long
Dim iStopRow As Long
Dim sSectionName As String
Dim rCell As Range
Dim Payments As Workbook
Dim sFilePath As String
Dim iCount As Integer
iCol = Application.InputBox("Enter the column number used for splitting", "Select column", 2, , , , , 1)
iRow = Application.InputBox("Enter the starting row number (to skip header)", "Select row", 5, , , , , 1)
iFirstRow = iRow
Set Master = Application.ActiveSheet
Set Payments = Application.ActiveWorkbook
iTotalRows = Master.UsedRange.Rows.Count
sFilePath = "M:\all\FI Payments\Single Participant Payment Worksheets\Split Files\"
'Turn Off Screen Updating Events
Application.EnableEvents = False
Application.ScreenUpdating = False
Do
' Get cell at cursor
Set rCell = Master.Cells(iRow, iCol)
sCell = Replace(rCell.Text, " ", "")
If sCell = "" Or (rCell.Text = sSectionName And iStartRow <> 0) Or InStr(1, rCell.Text, "total", vbTextCompare) <> 0 Then
' Skip condition met
Else
' Found new section
If iStartRow = 0 Then
' StartRow delimiter not set, meaning beginning a new section
sSectionName = rCell.Value
iStartRow = iRow
Else
' StartRow delimiter set, meaning we reached the end of a section
iStopRow = iRow - 1
' Pass variables to a separate sub to create and save the new worksheet
CopySheet Master, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, Payments.fileFormat
iCount = iCount + 1
' Reset section delimiters
iStartRow = 0
iStopRow = 0
' Ready to continue loop
iRow = iRow - 1
End If
End If
' Continue until last row is reached
If iRow < iTotalRows Then
iRow = iRow + 1
Else
' Finished. Save the last section
iStopRow = iRow
CopySheet Master, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, Payments.fileFormat
iCount = iCount + 1
' Exit
Exit Do
End If
Loop
'Turn On Screen Updating Events
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox Str(iCount) + " documents saved in " + sFilePath
End Sub
Public Sub DeleteRows(targetSheet As Worksheet, RowFrom As Long, RowTo As Long)
Dim rngRange As Range
Set rngRange = Range(targetSheet.Cells(RowFrom, 1), targetSheet.Cells(RowTo, 1)).EntireRow
rngRange.Select
rngRange.Delete
End Sub
Public Sub CopySheet(Master As Worksheet, iFirstRow As Long, iStartRow As Long, iStopRow As Long, iTotalRows As Long, sFilePath As String, sSectionName As String, fileFormat As XlFileFormat)
Dim ash As Worksheet ' Copied sheet
Dim awb As Workbook ' New workbook
' Copy book
Master.Copy
Set ash = Application.ActiveSheet
' Delete Rows after section
If iTotalRows > iStopRow Then
DeleteRows ash, iStopRow + 1, iTotalRows
End If
' Delete Rows before section
If iStartRow > iFirstRow Then
DeleteRows ash, iFirstRow, iStartRow - 1
End If
' Select left-topmost cell
ash.Cells(1, 1).Select
' Save in same format as original workbook
ash.SaveAs sFilePath + sSectionName, fileFormat
' Close
Set awb = ash.Parent
awb.Close SaveChanges:=False
End Sub