Break up column A content between column A and B

[gmaxey]

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

[YasserKhalil]

Hello Mr. Greg
After those lines

    If UBound(varFileList) = -1 Then
        MsgBox "There are no files in the selected root folder.", vbOKOnly, "NO FILES"
        GoTo lbl_Exit
    End If

I have added those lines

    Dim i As Long
    Dim k As Long
    Dim b As Variant
    Dim p As Long


    ReDim b(1 To UBound(varFileList) + 1, 1 To 2)
    For i = LBound(varFileList) To UBound(varFileList)
        If varFileList(i) <> "" Then
            k = k + 1
            p = InStrRev(varFileList(i), "\")
            b(k, 1) = Mid(varFileList(i), 1, p)
            b(k, 2) = Mid(varFileList(i), p + 1, Len(varFileList(i)))
        End If
    Next i

Then I have commented out some lines (not sure of those lines in fact) and added one line at the end

    '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
    m_oSheet.Range("A1").Resize(k, UBound(b, 2)).Value = b

Hope that helps

[mdmackillop]

Another version

 m_oTarget.Range.Text = Join(varFileList, "|")
    Dim x, i, Arr()
    
    x = Split(m_oTarget.Range.Text, "|")
    ReDim Arr(UBound(x), 1)
    For i = 0 To UBound(x)
     Arr(i, 1) = Split(x(i), "\")(UBound(Split(x(i), "\")))
     Arr(i, 0) = Left(x(i), Len(x(i)) - Len(Arr(i, 1)))
    Next i
    m_oSheet.Range("A1").Resize(UBound(x) + 1, 2) = Arr

[gmaxey]

Thanks for the information both of you. I won't be back at a PC with Word until tomorrow but either methods certainly looks like they will work. When I see the result, I may have a follow up question. Thanks again.

[snb]

This code suffices:

Sub M_snb()
    c00 = "D:\Word\"
    sn = Split(CreateObject("wscript.shell").exec("cmd /c dir """ & c00 & "*.*"" /a-d /s /b /on").stdout.readall, vbCrLf)
    If UBound(sn) = -1 Then Exit Sub
        
    For j = 0 To UBound(sn) - 1
       c01 = Dir(sn(j))
       sn(j) = Left(sn(j), Len(sn(j)) - Len(c01)) & ";" & c01
    Next
    CreateObject("scripting.filesystemobject").createtextfile("G:\OF\snb.csv").write Join(sn, vbCrLf)
    
    GetObject("G:\OF\snb.csv").Windows(1).Visible = True
End Sub

0. always end a path with a backslash
1. you can sort in wscript.shell
2. Use a comma or semicolon to split into columns, dependent of your international settings
3. If speed is crucial you shouldn't use messageboxes

[gmaxey]

I went with a slightly modified version of YasserKhalil's code as it didn't require the extra step of creating and then killing the Word file. I modified it so I could put the file name in column A with the path in column B then sort on column A if desired.

One follow up question. In original code I posted I have this line:

'oShell.Run "cmd /c Dir /s /o /b """ & strFolder & """ > d:\Result.txt", 0

I notice that when I use Shell.run in that manner then I never see the cmd prompt. However, using Shell.Exec does show the command prompt. On a small folder it is just a flash and not and issue but in a very large folder, it can show for several seconds. This could be disconcerting for users. Do any of you know how to suppress the command prompt from being displayed?

Thanks again. I feel stupid, but I don't know how to mark a thread solved.

[mdmackillop]

how to mark a thread solved

See thread tools just above the first post.