File Splitter Add-In

Rich2xh · Dec 15th 2021

Hi,

Recently left a job where someone kindly created a 'file cutter' add in for our dept, and would appreciate any help in recreating this. It basically cut one sheet into separate workbooks based values in a single column, and also gave the option to include other (untouched) tabs in the new workbook - e.g. sheets with tables or charts that link to the original sheet data.

The tool worked in this order:

1. First prompt box opened, asking user to select

a. The sheet to cut

b. The column to cut the sheet by

c. The header row

d. First row of data (defaulted to the row below 1.c.)

e. Last row of data (defaulted to the last row containing data in the sheet)

f. The other tabs in the file to copy to the new workbook (listing every other sheet, hidden or otherwise, present in the workbook)

2. Second prompt box opened, asking user to select

a. Which values in the column selected in 1.b. to produce cuts of

b. The naming convention of the new workbooks - two text boxes in following format: <free text> & [cut name] & <free text>

c. The password to apply to each new workbook

3. Start button would then trigger the VBA to run the following process - all happening in the background (i.e. not visible):

a. Save the file

b. Save the file with the naming convention in 2.b. for the first cut

c. Clear all filters in sheet to cut (1.a.)

d. Filter and delete the non-relevant rows, then clear filters

e. Delete any tabs not selected in 1.a. & 1.f.

f. Save the file with the password defined in 2.c., then close the file

g. Reopen the original file, and repeat from 3.a., until all values selected in 2.a. have had a new workbook created for them

h. End

**royUK** · Dec 15th 2021

Here's some basic code.

Code

'Move to workbooks

Option Explicit

Sub ExtractToSheets()
    Dim ws As Worksheet, wsNew As Worksheet
    Dim rData As Range, rCl As Range
    Dim sNm As String
   Const iCol As Integer = 3 ''///- currently uses Column 3
    
    Set ws = Sheet1    '/// you may need to change this
    
    '///extract a list of unique names
    '///first clear existing list
    With ws
        Set rData = .Range("A1").CurrentRegion
        .Columns(.Columns.Count).Clear
        rData.Columns(iCol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True
        
        For Each rCl In .Cells(1, .Columns.Count).CurrentRegion
            sNm = rCl.Text
            '///add new sheet (only if required-NB uses UDF below)
            If WksExists(sNm) Then
                '///so clear contents
                Sheets(sNm).Cells.Clear
            Else
                '///new sheet required
                Set wsNew = Sheets.Add
                With wsNew
                    .Name = sNm
                    '///AutoFilter & copy to relevant sheet
                    rData.AutoFilter Field:=iCol, Criteria1:=sNm ''/// currently filters column 3
                    rData.Copy Destination:=.Cells(1, 1)
                    .Move
                    '/// saves to a folder in the master workbook's directory
                    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\New Folder Name" & sNm, _
                    FileFormat:=51, CreateBackup:=False
                    ''///close and save new workbook
                    ActiveWorkbook.Close True
                End With
            End If
        Next rCl
    End With
    '\\\tidy up
    ws.Columns(Columns.Count).ClearContents        'remove temporary list
    rData.AutoFilter        'switch off AutoFilter
End Sub


Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

Display More

Your requirement is achievable but really not a Forum question. Have you searched for an addin?

File Splitter Add-In

Participate now!

Share

Tags