gmaxey
08-14-2017, 01:50 PM
Hello Excel Experts,
A Word nub coming here with a hand out for some Excel assistance please.
I have a process that I run from a Word Ribbon Tab the creates a file list in Excel (code follows). It is very fast, but the issue is that all the data i.e., File Path and File Name is listed in column A. I need to spilt out the file name part from the existing data in column A and write it to column be.
eg.,
D:\Word\Letter.docm
D:\Word\Flyers\Flyer 1.docm
D:\Word\Flyers\Flyer 2.docm
I think I might be able to create an array from each Cell A data and put the last element in column b and all but the last back in column A, but I'm afraid that I would give up a lot of speed by looping through each row.
I'm hoping someone may know of a way to split the cell values at the last "/" and with a result of two columns.
Also open to other solutions, but speed is paramount. thanks
Option Explicit
Private m_oTarget As Document
Dim m_oXL As Object
Dim m_oWB As Object
Dim m_oSheet As Object
Sub ListFolder()
Dim strPath As String
Dim varFileList
strPath = "D:\Word"
varFileList = fcnGetList(strPath, 1)
'varFileList = fcnGetList(strPath, 2)
MsgBox UBound(varFileList)
If UBound(varFileList) = -1 Then
MsgBox "There are no files in the selected root folder.", vbOKOnly, "NO FILES"
GoTo lbl_Exit
End If
'Check if Excel is installed and already running. If not then start Excel
On Error Resume Next
Set m_oXL = GetObject(, "Excel.Application")
If m_oXL Is Nothing Then
Set m_oXL = CreateObject("Excel.Application")
If m_oXL Is Nothing Then
MsgBox "Excel not installed. Please contact your local IT staff."
Exit Sub
End If
End If
On Error GoTo Err_Handler1
Set m_oWB = m_oXL.Workbooks.Add
Set m_oSheet = m_oWB.Sheets(1)
Set m_oTarget = Documents.Add(ThisDocument.AttachedTemplate.FullName, , , False)
m_oTarget.Range.Text = Join(varFileList, vbCrLf)
m_oTarget.Range.Copy
m_oSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
m_oSheet.Sort.SortFields.Clear
m_oSheet.Sort.SortFields.Add Key:=m_oSheet.Range("A1"), SortOn:=0, Order:=1, DataOption:=0
With m_oSheet.Sort
.SetRange m_oSheet.UsedRange
.Header = 2
.MatchCase = False
.Orientation = 1
.SortMethod = 1
.Apply
End With
m_oTarget.Close wdDoNotSaveChanges
m_oXL.Visible = True
m_oXL.Columns("A:D").EntireColumn.AutoFit
lbl_Exit:
Set m_oTarget = Nothing
Set m_oXL = Nothing
Set m_oWB = Nothing
Set m_oSheet = Nothing
Exit Sub
Err_Handler1:
MsgBox Err.Description, vbCritical, "Error: " & Err.Number
If Not m_oXL Is Nothing Then
m_oXL.Quit
End If
Resume lbl_Exit
End Sub
Function fcnGetList(strFolder, lngRouter)
Dim oShell As Object
Set oShell = VBA.CreateObject("WScript.Shell")
'oShell.Run "cmd /c Dir /s /o /b """ & strFolder & """ > d:\Result.txt", 0
'fcnGetList = Split(oShell.Exec("cmd /c Dir """ & strFolder & """ /s/o/b").StdOut.ReadAll, vbCrLf)
Select Case lngRouter
Case 1: fcnGetList = Split(oShell.Exec("cmd /c Dir """ & strFolder & """ /a:-d/s/o/b").StdOut.ReadAll, vbCrLf)
Case 2: fcnGetList = Split(oShell.Exec("cmd /c Dir """ & strFolder & """ /a:-d/o/b").StdOut.ReadAll, vbCrLf)
End Select
Set oShell = Nothing
lbl_Exit:
Exit Function
End Function
Public Function fcnFileOrFolderExist(PathName As String) As Boolean
'Macro Purpose: Function returns TRUE if the specified file or folder exists, false if not.
'PathName: Supports Windows mapped drives
'File usage: Provide full file path and extension
'Folder usage: Provide full folder path
Dim lngTemp As Long
'Ignore errors to allow for error evaluation
On Error Resume Next
lngTemp = GetAttr(PathName)
'Check if error exists and set response appropriately
Select Case Err.Number
Case Is = 0
fcnFileOrFolderExist = True
Case Else
fcnFileOrFolderExist = False
End Select
'Resume error checking
On Error GoTo 0
lbl_Exit:
Exit Function
End Function
A Word nub coming here with a hand out for some Excel assistance please.
I have a process that I run from a Word Ribbon Tab the creates a file list in Excel (code follows). It is very fast, but the issue is that all the data i.e., File Path and File Name is listed in column A. I need to spilt out the file name part from the existing data in column A and write it to column be.
eg.,
D:\Word\Letter.docm
D:\Word\Flyers\Flyer 1.docm
D:\Word\Flyers\Flyer 2.docm
I think I might be able to create an array from each Cell A data and put the last element in column b and all but the last back in column A, but I'm afraid that I would give up a lot of speed by looping through each row.
I'm hoping someone may know of a way to split the cell values at the last "/" and with a result of two columns.
Also open to other solutions, but speed is paramount. thanks
Option Explicit
Private m_oTarget As Document
Dim m_oXL As Object
Dim m_oWB As Object
Dim m_oSheet As Object
Sub ListFolder()
Dim strPath As String
Dim varFileList
strPath = "D:\Word"
varFileList = fcnGetList(strPath, 1)
'varFileList = fcnGetList(strPath, 2)
MsgBox UBound(varFileList)
If UBound(varFileList) = -1 Then
MsgBox "There are no files in the selected root folder.", vbOKOnly, "NO FILES"
GoTo lbl_Exit
End If
'Check if Excel is installed and already running. If not then start Excel
On Error Resume Next
Set m_oXL = GetObject(, "Excel.Application")
If m_oXL Is Nothing Then
Set m_oXL = CreateObject("Excel.Application")
If m_oXL Is Nothing Then
MsgBox "Excel not installed. Please contact your local IT staff."
Exit Sub
End If
End If
On Error GoTo Err_Handler1
Set m_oWB = m_oXL.Workbooks.Add
Set m_oSheet = m_oWB.Sheets(1)
Set m_oTarget = Documents.Add(ThisDocument.AttachedTemplate.FullName, , , False)
m_oTarget.Range.Text = Join(varFileList, vbCrLf)
m_oTarget.Range.Copy
m_oSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
m_oSheet.Sort.SortFields.Clear
m_oSheet.Sort.SortFields.Add Key:=m_oSheet.Range("A1"), SortOn:=0, Order:=1, DataOption:=0
With m_oSheet.Sort
.SetRange m_oSheet.UsedRange
.Header = 2
.MatchCase = False
.Orientation = 1
.SortMethod = 1
.Apply
End With
m_oTarget.Close wdDoNotSaveChanges
m_oXL.Visible = True
m_oXL.Columns("A:D").EntireColumn.AutoFit
lbl_Exit:
Set m_oTarget = Nothing
Set m_oXL = Nothing
Set m_oWB = Nothing
Set m_oSheet = Nothing
Exit Sub
Err_Handler1:
MsgBox Err.Description, vbCritical, "Error: " & Err.Number
If Not m_oXL Is Nothing Then
m_oXL.Quit
End If
Resume lbl_Exit
End Sub
Function fcnGetList(strFolder, lngRouter)
Dim oShell As Object
Set oShell = VBA.CreateObject("WScript.Shell")
'oShell.Run "cmd /c Dir /s /o /b """ & strFolder & """ > d:\Result.txt", 0
'fcnGetList = Split(oShell.Exec("cmd /c Dir """ & strFolder & """ /s/o/b").StdOut.ReadAll, vbCrLf)
Select Case lngRouter
Case 1: fcnGetList = Split(oShell.Exec("cmd /c Dir """ & strFolder & """ /a:-d/s/o/b").StdOut.ReadAll, vbCrLf)
Case 2: fcnGetList = Split(oShell.Exec("cmd /c Dir """ & strFolder & """ /a:-d/o/b").StdOut.ReadAll, vbCrLf)
End Select
Set oShell = Nothing
lbl_Exit:
Exit Function
End Function
Public Function fcnFileOrFolderExist(PathName As String) As Boolean
'Macro Purpose: Function returns TRUE if the specified file or folder exists, false if not.
'PathName: Supports Windows mapped drives
'File usage: Provide full file path and extension
'Folder usage: Provide full folder path
Dim lngTemp As Long
'Ignore errors to allow for error evaluation
On Error Resume Next
lngTemp = GetAttr(PathName)
'Check if error exists and set response appropriately
Select Case Err.Number
Case Is = 0
fcnFileOrFolderExist = True
Case Else
fcnFileOrFolderExist = False
End Select
'Resume error checking
On Error GoTo 0
lbl_Exit:
Exit Function
End Function