loop through all workbooks and split into sheets by month

rjmdc

Well-known Member
Joined
Apr 29, 2020
Messages
703
Office Version
  1. 365
Platform
  1. Windows
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

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
 

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.

Forum statistics

Threads
1,223,885
Messages
6,175,183
Members
452,615
Latest member
bogeys2birdies

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