Avatar of Ted Penner
Ted Penner
Flag for United States of America

asked on 

Process filename extension

I had this question after viewing Named range not carried over.

The filename extension that is created for each file created when this macro runs is left off if the filename has a period elsewhere in the name.  Assistance in correcting this minor problem is greatly appreciated.

Sub Separate_by_Filename_Column_Into_Separate_Workbooks()

'This routine will separate the active sheet into separate workbook files
'based on the filename given in the filename column.
'If this workbook contains a sheet (tab) named "Validate" with named ranges for validation,
'and with validation columns in the original sheet, it should keep the named ranges,
'and the validation columns, as well as the name of the originating sheet.

Dim aFiles As Variant

strDirectory = GetFolder(ActiveWorkbook.path)
If strDirectory = "" Then Exit Sub
Set origSh = ActiveSheet
Set rngFound = Nothing
On Error Resume Next
Set rngFound = Range("1:1").Find("Filename")
On Error GoTo 0
If Not rngFound Is Nothing Then
    strCol = Split(rngFound.Address, "$")(1)
    Set myRange = Range(Range(strCol & "2"), Range(strCol & Rows.Count).End(xlUp))
    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))
    Application.DisplayAlerts = True
    For Each C In aFiles
        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
            For Each ar In origRng.Areas
        End If
        origSh.Parent.Sheets("Validate").Copy after:=newSh
        newWbk.Sheets("Validate").Visible = xlSheetHidden
        newSh.Name = Left(C, 31)
        newWbk.SaveAs strDirectory & "\" & C
        newWbk.Close False
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
GetFolder = sItem
Set fldr = Nothing
End Function

Open in new window

VB ScriptMicrosoft ExcelShell ScriptingScripting LanguagesSystem Programming

Avatar of undefined
Last Comment
Ejgil Hedegaard

8/22/2022 - Mon