PDA

View Full Version : [SOLVED] Break up column A content between column A and B



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

YasserKhalil
08-14-2017, 02:22 PM
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
08-14-2017, 02:34 PM
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
08-14-2017, 05:10 PM
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
08-15-2017, 02:01 AM
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
08-15-2017, 09:09 AM
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
08-15-2017, 09:19 AM
how to mark a thread solved
See thread tools just above the first post.