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, 11) < 10 Then Exit Sub
Set mRng = shMaster.Range("K10:K" & lrow(shMaster, 11))
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
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Private Sub GetEmployerList(ByVal empRng As Range) 'get list of all employers with no duplicate
Dim cll As Range
Dim shEmp As Worksheet
Dim empList As Range
Dim i As Integer
Dim emp() As String
Sheets.Add After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) 'create new sheet to list all employer
Set shEmp = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
For Each cll In empRng
emp = Split(cll.Value, "/") 'split employer when cell has more than 1, separator is "/"
For i = LBound(emp) To UBound(emp)
Set empList = shEmp.Range("A1:A" & lrow(shEmp, 1))
If CustomMatch(Left(emp(i), 220), empList) = False Then
shEmp.Cells(lrow(shEmp, 1) + 1, 1).Value = Left(emp(i), 220) 'limit with 220 characters
End If
Next i
Next cll
End Sub
Private Sub SplitEmployer(ByVal emp As String, ByVal rng As Range) 'split all employers from master workbook base on sheet employer list
Dim cll As Range
Dim i As Integer
Dim j As Integer
Dim wbOut As Workbook
Dim shOut As Worksheet
Workbooks.Add 'create new workbook
Set wbOut = ActiveWorkbook
Set shOut = wbOut.Sheets(1)
ThisWorkbook.Sheets("LIST").Range("A1:K9").Copy 'copy header of master sheet
shOut.Cells(1, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
For Each cll In rng
If InStr(cll.Value, emp) > 0 Then 'condition when found matched employer
If lrow(shOut, 11) < 10 Then
j = 10
Else
j = lrow(shOut, 11) + 1
End If
For i = 0 To 10
shOut.Cells(j, 11 - i).Value = cll.Offset(, -i).Value
Next i
End If
Next cll
wbOut.SaveAs Filename:=ThisWorkbook.Path & "\" & emp & ".xlsx" 'save new workbook with employer name and close
wbOut.Close
End Sub
Private Function lrow(ByVal sh As Worksheet, ByVal col As Integer) As Long 'find last row of table
lrow = sh.Cells(Rows.Count, col).End(xlUp).Row
End Function
Private Function CustomMatch(ByVal xVal As String, ByVal rng As Range) As Boolean 'find match employer
Dim cll As Range
For Each cll In rng
If cll.Value = xVal Then
CustomMatch = True
Exit For
Else
CustomMatch = False
End If
Next cll
End Function
