asked on

Debug Excel file separation tool

I had this question after viewing Separate into files by filename.

The macro below does create separate files according to unique filenames as identified in the filename column, but it also re-adjusts the ordering in the original file which it should not do.

The macro also seems the row for the first filename in each of the separated workbooks along with the rows for the ones that were separated correctly.

I have included the macro below, the original workbook that the macro gets run against, as well as the resulting files that were created.

Sub Separate_by_FilenameByShs()

Set origSh = ActiveSheet
Set rngFound = Nothing
Set rngFound = Range("1:1").Find("Filename")
If Not rngFound Is Nothing Then
    strCol = Split(rngFound.Address, "$")(1)
    For Each C In Range(Range(strCol & "2"), Range(strCol & Rows.Count).End(xlUp))
        If Not Evaluate("=ISREF('" & C & "'!A1)") Then
            origSh.UsedRange.AutoFilter Field:=rngFound.Column, Criteria1:=C.Value, VisibleDropDown:=True
            ActiveWorkbook.Sheets.Add after:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
            ActiveSheet.Name = C
            origSh.UsedRange.Copy
            ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
            origSh.Range(origSh.Range("A1"), origSh.Range("A1").SpecialCells(xlCellTypeLastCell)).EntireRow.Copy ActiveSheet.Range("A1")
            ActiveSheet.UsedRange.AutoFilter
            origSh.Activate
        End If
    Next
End If
End Sub
Sub Separate_by_FilenameByWbks()

strDirectory = GetFolder(ActiveWorkbook.Path)
If strDirectory = "" Then Exit Sub
Set origSh = ActiveSheet
Set rngFound = Nothing
Set rngFound = Range("1:1").Find("Filename")
If Not rngFound Is Nothing Then
    Worksheets("Separate test data").AutoFilter.Sort.SortFields.Clear
    Worksheets("Separate test data").AutoFilter.Sort.SortFields.Add _
        Key:=Cells(1, rngFound.Column), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    With ActiveWorkbook.Worksheets("Separate test data").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    strCol = Split(rngFound.Address, "$")(1)
    For Each C In Range(Range(strCol & "2"), Range(strCol & Rows.Count).End(xlUp))
        If C <> C.Offset(-1) Then
            origSh.Copy
            Set newWbk = ActiveWorkbook
            Set newSh = newWbk.ActiveSheet
            newSh.UsedRange.AutoFilter Field:=rngFound.Column, Criteria1:="<>" & C.Value, VisibleDropDown:=True
            Set origRng = Nothing
            On Error Resume Next
            Set origRng = newSh.Range(Range(strCol & "2"), Range(strCol & Rows.Count).End(xlUp)).Offset(1, 1).SpecialCells(xlCellTypeVisible).EntireRow
            On Error GoTo 0
            If Not origRng Is Nothing Then origRng.Delete
            newSh.UsedRange.AutoFilter
            newWbk.SaveAs strDirectory & "\" & C
            newWbk.Close False
        End If
    Next
End If
End Sub
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = strPath
    If .Show <> -1 Then GoTo NextCode
    sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function

Open in new window

160405-Separate-This-Test-Data-test.xlsb File1.xlsx File2.xlsx File3.xlsx File4.xlsx File5.xlsx

Rgonzo1971

Hi,

pls try

Sub Separate_by_Filename()

res = MsgBox("Do you want to separate by Workbooks (Yes)" & vbCrLf & _
        "or do you want to separate by Sheets (No)?", vbYesNoCancel)
If res = vbYes Then
    Separate_by_FilenameByWbks
ElseIf res = vbNo Then
    Separate_by_FilenameByShs
Else
'Cancel
End If
End Sub
Sub Separate_by_FilenameByShs()

Set origSh = ActiveSheet
Set rngFound = Nothing
Set rngFound = Range("1:1").Find("Filename")
If Not rngFound Is Nothing Then
    strCol = Split(rngFound.Address, "$")(1)
    For Each c In Range(Range(strCol & "2"), Range(strCol & Rows.Count).End(xlUp))
        If Not Evaluate("=ISREF('" & c & "'!A1)") Then
            origSh.UsedRange.AutoFilter Field:=rngFound.Column, Criteria1:=c.Value, VisibleDropDown:=True
            ActiveWorkbook.Sheets.Add after:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
            ActiveSheet.Name = c
            origSh.UsedRange.Copy
            ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
            origSh.Range(origSh.Range("A1"), origSh.Range("A1").SpecialCells(xlCellTypeLastCell)).EntireRow.Copy ActiveSheet.Range("A1")
            ActiveSheet.UsedRange.AutoFilter
            origSh.Activate
        End If
    Next
End If
End Sub
Sub Separate_by_FilenameByWbks()
Dim aFiles As Variant
strDirectory = GetFolder(ActiveWorkbook.Path)
If strDirectory = "" Then Exit Sub
Set origSh = ActiveSheet
Set rngFound = Nothing
Set rngFound = Range("1:1").Find("Filename")
If Not rngFound Is Nothing Then
    strCol = Split(rngFound.Address, "$")(1)
    Set myRange = Range(Range(strCol & "2"), Range(strCol & Rows.Count).End(xlUp))
    ActiveWorkbook.Sheets.Add
    myRange.Copy ActiveSheet.Range("A1")
    Application.DisplayAlerts = False
    Range(Range("A1"), Range("A" & Rows.Count).End(xlUp)).RemoveDuplicates Columns:=1, Header:=xlNo
    aFiles = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
    ActiveSheet.Delete
    Application.DisplayAlerts = True
    For Each c In aFiles
        origSh.Copy
        Set newWbk = ActiveWorkbook
        Set newSh = newWbk.ActiveSheet
        newSh.UsedRange.AutoFilter Field:=rngFound.Column, Criteria1:="<>" & c, VisibleDropDown:=True
        Set origRng = Nothing
        On Error Resume Next
        Set origRng = newSh.Range(Range(strCol & "2"), Range(strCol & Rows.Count).End(xlUp)).Offset(1, 1).SpecialCells(xlCellTypeVisible).EntireRow
        On Error GoTo 0
        If Not origRng Is Nothing Then origRng.Delete
        newSh.UsedRange.AutoFilter
        newWbk.SaveAs strDirectory & "\" & c
    Next
End If
End Sub
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = strPath
    If .Show <> -1 Then GoTo NextCode
    sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function

Open in new window

Regards

Ted Penner

ASKER

Thanks for the assistance.

Unfortunately, it still appears to disorganize the original sheet.

It still appears to place the first filename into the top row of each new workbook.

We also only need to debug the code pasted below without the module that asks whether sheets or workbooks.

Sub Separate_by_FilenameByShs()

Set origSh = ActiveSheet
Set rngFound = Nothing
Set rngFound = Range("1:1").Find("Filename")
If Not rngFound Is Nothing Then
    strCol = Split(rngFound.Address, "$")(1)
    For Each c In Range(Range(strCol & "2"), Range(strCol & Rows.Count).End(xlUp))
        If Not Evaluate("=ISREF('" & c & "'!A1)") Then
            origSh.UsedRange.AutoFilter Field:=rngFound.Column, Criteria1:=c.Value, VisibleDropDown:=True
            ActiveWorkbook.Sheets.Add after:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
            ActiveSheet.Name = c
            origSh.UsedRange.Copy
            ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
            origSh.Range(origSh.Range("A1"), origSh.Range("A1").SpecialCells(xlCellTypeLastCell)).EntireRow.Copy ActiveSheet.Range("A1")
            ActiveSheet.UsedRange.AutoFilter
            origSh.Activate
        End If
    Next
End If
End Sub
Sub Separate_by_FilenameByWbks()
Dim aFiles As Variant
strDirectory = GetFolder(ActiveWorkbook.Path)
If strDirectory = "" Then Exit Sub
Set origSh = ActiveSheet
Set rngFound = Nothing
Set rngFound = Range("1:1").Find("Filename")
If Not rngFound Is Nothing Then
    strCol = Split(rngFound.Address, "$")(1)
    Set myRange = Range(Range(strCol & "2"), Range(strCol & Rows.Count).End(xlUp))
    ActiveWorkbook.Sheets.Add
    myRange.Copy ActiveSheet.Range("A1")
    Application.DisplayAlerts = False
    Range(Range("A1"), Range("A" & Rows.Count).End(xlUp)).RemoveDuplicates Columns:=1, Header:=xlNo
    aFiles = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
    ActiveSheet.Delete
    Application.DisplayAlerts = True
    For Each c In aFiles
        origSh.Copy
        Set newWbk = ActiveWorkbook
        Set newSh = newWbk.ActiveSheet
        newSh.UsedRange.AutoFilter Field:=rngFound.Column, Criteria1:="<>" & c, VisibleDropDown:=True
        Set origRng = Nothing
        On Error Resume Next
        Set origRng = newSh.Range(Range(strCol & "2"), Range(strCol & Rows.Count).End(xlUp)).Offset(1, 1).SpecialCells(xlCellTypeVisible).EntireRow
        On Error GoTo 0
        If Not origRng Is Nothing Then origRng.Delete
        newSh.UsedRange.AutoFilter
        newWbk.SaveAs strDirectory & "\" & c
    Next
End If
End Sub
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = strPath
    If .Show <> -1 Then GoTo NextCode
    sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function

Open in new window

Rgonzo1971

then try

the code now shouldnt reorder the column Filename

Sub Separate_by_FilenameByWbks()
Dim aFiles As Variant
strDirectory = GetFolder(ActiveWorkbook.Path)
If strDirectory = "" Then Exit Sub
Set origSh = ActiveSheet
Set rngFound = Nothing
Set rngFound = Range("1:1").Find("Filename")
If Not rngFound Is Nothing Then
    strCol = Split(rngFound.Address, "$")(1)
    Set myRange = Range(Range(strCol & "2"), Range(strCol & Rows.Count).End(xlUp))
    ActiveWorkbook.Sheets.Add
    myRange.Copy ActiveSheet.Range("A1")
    Application.DisplayAlerts = False
    Range(Range("A1"), Range("A" & Rows.Count).End(xlUp)).RemoveDuplicates Columns:=1, Header:=xlNo
    aFiles = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
    ActiveSheet.Delete
    Application.DisplayAlerts = True
    For Each c In aFiles
        origSh.Copy
        Set newWbk = ActiveWorkbook
        Set newSh = newWbk.ActiveSheet
        Set myNewRange = Range(Range(strCol & "1"), Range(strCol & Rows.Count).End(xlUp))
        myNewRange.AutoFilter Field:=rngFound.Column, Criteria1:="<>" & c, VisibleDropDown:=True
        Set origRng = Nothing
        On Error Resume Next
        Set origRng = newSh.Range(Range(strCol & "2"), Range(strCol & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).EntireRow
        On Error GoTo 0
        If Not origRng Is Nothing Then origRng.Delete
        newSh.UsedRange.AutoFilter
        newWbk.SaveAs strDirectory & "\" & c
    Next
End If
End Sub
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = strPath
    If .Show <> -1 Then GoTo NextCode
    sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function

Open in new window

Ted Penner

ASKER

This one is better but does appear to re-organize the original. Ideally, it should not leave anything on the screen. Maybe it should say Complete or something.

It also doesn't keep the colorization or original filtering.

Rgonzo1971

then try

Sub Separate_by_FilenameByWbks()
Dim aFiles As Variant
strDirectory = GetFolder(ActiveWorkbook.Path)
If strDirectory = "" Then Exit Sub
Set origSh = ActiveSheet
Set rngFound = Nothing
Set rngFound = Range("1:1").Find("Filename")
If Not rngFound Is Nothing Then
    strCol = Split(rngFound.Address, "$")(1)
    Set myRange = Range(Range(strCol & "2"), Range(strCol & Rows.Count).End(xlUp))
    ActiveWorkbook.Sheets.Add
    myRange.Copy ActiveSheet.Range("A1")
    Application.DisplayAlerts = False
    Range(Range("A1"), Range("A" & Rows.Count).End(xlUp)).RemoveDuplicates Columns:=1, Header:=xlNo
    aFiles = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
    ActiveSheet.Delete
    Application.DisplayAlerts = True
    For Each c In aFiles
        origSh.Copy
        Set newWbk = ActiveWorkbook
        Set newSh = newWbk.ActiveSheet
        Set myNewRange = Range(Range(strCol & "1"), Range(strCol & Rows.Count).End(xlUp))
        myNewRange.AutoFilter Field:=rngFound.Column, Criteria1:="<>" & c, VisibleDropDown:=True
        Set origRng = Nothing
        On Error Resume Next
        Set origRng = newSh.Range(Range(strCol & "2"), Range(strCol & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).EntireRow
        On Error GoTo 0
        If Not origRng Is Nothing Then origRng.Delete
        newWbk.SaveAs strDirectory & "\" & c
        newWbk.Close False
    Next
End If
End Sub
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = strPath
    If .Show <> -1 Then GoTo NextCode
    sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function

Open in new window

Could you be more precise with

It also doesn't keep the colorization or original filtering.

ASKER CERTIFIED SOLUTION

Rgonzo1971

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Ted Penner

ASKER

The one you have in your last reply, PostID #213 is looking pretty good. It leaves the table with the minor problem of colorization afterward. See screenshot

Ted Penner

ASKER

will ask new question

This one does the separation better than anything we have thus far.

Ted Penner

ASKER

New question >> https://www.experts-exchange.com/questions/28938143/Debug-file-separation.html