Split master data into multiple workbooks with header

[ibbara]

Hello there,

I'm searching for a macro that split data into multiple workbook. The splitted name will be the employer name with maximum of 120 characters in name when saving and having the 8 rows as header.

We are sending billing statement from different company. This will be a very very big help to us

 

[eiloken]

Hello eiloken its perfectly working i am so very thankful. Thank you very much.

Can i ask what code will i change if i have headings from A6 to Q6? I'm trying to change the code but its not working. I'm not that knowledgeable ing vba.
Thank you very much

It hard to be modify when i can't image your form, so give me a screenshot and we will see what we need to do

 

[ibbara]

It hard to be modify when i can't image your form, so give me a screenshot and we will see what we need to do

This is the 2nd file I used to email multiple companies. Its almost the same but have more columns.

Thank you

 

[eiloken]

This is the 2nd file I used to email multiple companies. Its almost the same but have more columns.

Thank you

look like the column used for split workbooks is "EYERNAME" so i change 2 subs like this:

Sub SplitEmployerList()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim shMaster As Worksheet
    Dim shEmp As Worksheet
    Dim cll As Range
    Dim mRng As Range
    Dim eRng As Range
    Set shMaster = ThisWorkbook.Sheets("LIST")
    If lrow(shMaster, 9) < 7 Then Exit Sub 'change to sheet master eyername column
    Set mRng = shMaster.Range("I7:I" & lrow(shMaster, 9)) 'change to sheet master eyername column
    Call GetEmployerList(mRng)
    Set shEmp = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    Set eRng = shEmp.Range("A1:A" & lrow(shEmp, 1))
    For Each cll In eRng
        If Not IsEmpty(cll) Then
            Call SplitEmployer(cll.Value, mRng)
        End If
    Next cll
    MsgBox "done"
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

And

Private Sub SplitEmployer(ByVal emp As String, ByVal rng As Range)
    Dim cll As Range
    Dim i As Integer
    Dim j As Integer
    Dim wbOut As Workbook
    Dim shOut As Worksheet
    Workbooks.Add
    Set wbOut = ActiveWorkbook
    Set shOut = wbOut.Sheets(1)
    shOut.Cells.NumberFormat = "@"
    ThisWorkbook.Sheets("LIST").Range("A1:Q6").Copy 'change to new title range
    shOut.Cells(1, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
    For Each cll In rng
        If InStr(cll.Value, emp) > 0 Then
            If lrow(shOut, 9) < 7 Then 'change to new eyername column of split sheet
                j = 7
            Else
                j = lrow(shOut, 9) + 1
            End If
            For i = 0 To 8
                shOut.Cells(j, 9 - i).Value = Format(cll.Offset(, -i).Value, "@") 'get all values with match eyername
                shOut.Cells(j, 9 + i).Value = Format(cll.Offset(, i).Value, "@")
            Next i
        End If
    Next cll
    shOut.Columns("A:Q").EntireColumn.AutoFit 'autofit new columns
    wbOut.SaveAs Filename:=ThisWorkbook.Path & "\" & emp & ".xlsx" 'this name is same as split workbook of master workbook before so make sure 2 master workbook isn't in same folder or split file will overwrite each other
    wbOut.Close
End Sub

Because this code save split workbooks with name of employer so if 2 master workbooks is in same folder, the split workbooks will overwrite each other so you need to place master workbooks in different folder or change this code for each workbook:
for the old one:

wbOut.SaveAs Filename:=ThisWorkbook.Path & "\" & emp & "_(PAG IBIG-FUND).xlsx"

for the new one:

wbOut.SaveAs Filename:=ThisWorkbook.Path & "\" & emp & "_(ABC-FUND).xlsx"

 

[ibbara]

Hello eiloken its working thank you very much on this. I really apprciated it. This will make my work a lot easier. More power to you

 

[ibbara]

Hello eiloken,

I reviewed some the same employer name of saved files. This one is saved with file name KKK TURBO FUEL CORPORATION, but there are another companies in the attachment list.

Thank you

 

[eiloken]

View attachment 100038
Hello eiloken,

I reviewed some the same employer name of saved files. This one is saved with file name KKK TURBO FUEL CORPORATION, but there are another companies in the attachment list.

Thank you

you can change sub SplitEmployer like the parts i mark, i don't test it now so feedback to me:

Private Sub SplitEmployer(ByVal emp As String, ByVal rng As Range)
    Dim cll As Range
    Dim i As Integer
    Dim j As Integer
    Dim splitEmp() As String 'add
    Dim k As Integer
    Dim wbOut As Workbook
    Dim shOut As Worksheet
    Workbooks.Add
    Set wbOut = ActiveWorkbook
    Set shOut = wbOut.Sheets(1)
    shOut.Cells.NumberFormat = "@"
    ThisWorkbook.Sheets("LIST").Range("A1:Q6").Copy
    shOut.Cells(1, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
    For Each cll In rng
        splitEmp = Split(cll.Value, "/") 'add
        For k = LBound(splitEmp) To UBound(splitEmp) 'add
            If splitEmp(k) = emp Then 'change
                If lrow(shOut, 9) < 7 Then
                    j = 7
                Else
                    j = lrow(shOut, 9) + 1
                End If
                For i = 0 To 8
                    shOut.Cells(j, 9 - i).Value = Format(cll.Offset(, -i).Value, "@")
                    shOut.Cells(j, 9 + i).Value = Format(cll.Offset(, i).Value, "@")
                Next i
                Exit For
            End If
        Next k
    Next cll
    shOut.Columns("A:Q").EntireColumn.AutoFit
    wbOut.SaveAs Filename:=ThisWorkbook.Path & "\" & emp & ".xlsx"
    wbOut.Close
End Sub

 

[ibbara]

you can change sub SplitEmployer like the parts i mark, i don't test it now so feedback to me:

Private Sub SplitEmployer(ByVal emp As String, ByVal rng As Range)
    Dim cll As Range
    Dim i As Integer
    Dim j As Integer
    Dim splitEmp() As String 'add
    Dim k As Integer
    Dim wbOut As Workbook
    Dim shOut As Worksheet
    Workbooks.Add
    Set wbOut = ActiveWorkbook
    Set shOut = wbOut.Sheets(1)
    shOut.Cells.NumberFormat = "@"
    ThisWorkbook.Sheets("LIST").Range("A1:Q6").Copy
    shOut.Cells(1, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
    For Each cll In rng
        splitEmp = Split(cll.Value, "/") 'add
        For k = LBound(splitEmp) To UBound(splitEmp) 'add
            If splitEmp(k) = emp Then 'change
                If lrow(shOut, 9) < 7 Then
                    j = 7
                Else
                    j = lrow(shOut, 9) + 1
                End If
                For i = 0 To 8
                    shOut.Cells(j, 9 - i).Value = Format(cll.Offset(, -i).Value, "@")
                    shOut.Cells(j, 9 + i).Value = Format(cll.Offset(, i).Value, "@")
                Next i
                Exit For
            End If
        Next k
    Next cll
    shOut.Columns("A:Q").EntireColumn.AutoFit
    wbOut.SaveAs Filename:=ThisWorkbook.Path & "\" & emp & ".xlsx"
    wbOut.Close
End Sub

Hello eiloken,

It's been a while. Sorry im not able to attend your reply.

I used this code but the data had moved in different column.

Im using the previous code. I just need to rename the duplicate employer name. Im ok with this.


I just want to ask if you can help me to change the format of column E to H as Accounting format?

Thank you very much

 

[eiloken]

Hello eiloken,

It's been a while. Sorry im not able to attend your reply.

I used this code but the data had moved in different column.

Im using the previous code. I just need to rename the duplicate employer name. Im ok with this.


I just want to ask if you can help me to change the format of column E to H as Accounting format?

Thank you very much

you can add: [shOut.Columns("E:H").NumberFormat = "0.00"] or [shOut.Columns("E:H").NumberFormat = "General"] after [shOut.Cells.NumberFormat = "@"]

 

[ibbara]

Hi eiloken

Thank you very much!

Perfectly working