Running List of CMD lines from Excel

Question

Can anyone help please with the following requirements?

Requirement A:

I'd like to create a loop to run a list of command strings in CMD as long as there's a non-zero value in column C. I think I need to define a variable i for my starting row as this will always be the same, and then run Shell(), pulling the command string from the corresponding cell in Row i, Column F. While Cells(i, "C") is not blank, keep going, increasing i by 1.

Requirement B:

I'd also like to link this macro to work in a directory deposited in a cell by an earlier macro that listed all the files in a selected directory.

This is what I have, without any looping..

Sub Run_Renaming()

    Dim CommandString As Long
    Dim i As Integer
    i = 5

    'Other steps:
        '1 - need to pick up variable (directory of files listed, taken from first macro
        'when doing manually, I opened command, went to correct directory, then pasted
        'the commands. I'm trying to handle pasting the commands. I'm not sure if I need
        'something to open CMD from VBA, then run through the below loop, or add opening
        'CMD and going to the directory in each iteration of the below loop...

        '2 - Need to say - Loop below text if Worksheets("Batch Rename of Files").Cells(i, "C").Value is no blank

         CommandString = Worksheets("Batch Rename of Files").Cells(i, "F").Value
         Call Shell("cmd.exe /S /K" & CommandString, vbNormalFocus)

    'Other steps:
        '3 - need to increase i by 1

        '4 - need to check if C column is blank or not

        '5 - need to end of C column is blank

End Sub

Background:

I'm creating a file renaming tool for a friend. They can use excel, but no programming languages or command prompt. Because of this, I don't want to have any steps, like creating a batch file suggested here, that would complicate things for my friend.

I've created an excel file with:

Tab 1 - a template sheet to create a new file name list. Works by concatenating several cells, adding a filetype, and outputting to a range of cells. Tab two links to this range when creating the renaming command strings for CMD

Tab 2 -

Button 1 - Sub rename() below. VBA to list files in a selected directory in Column C

Column F creates a command line that will rename File A as File B based on inputs to Tab 1 i.e. ren "File 1" "A1_B1_C1.xlsx"

Button 2 - Refers to a renaming macro (requirement 1 and 2 above) that picks up the selected directory from Button 1 and runs through all the renaming command strings while in that directory

Sub rename()

    Dim xRow As Long
    Dim xDirect$, xFname$, InitialFoldr$

    InitialFoldr$ = "C:\"

    Worksheets("Batch Rename of Files").Activate
    Worksheets("Batch Rename of Files").Range("C4").Activate

    With Application.FileDialog(msoFileDialogFolderPicker)

        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Please select a folder to list Files from"
        .InitialFileName = InitialFoldr$
        .Show

        If .SelectedItems.Count <> 0 Then

            xDirect$ = .SelectedItems(1) & "\"
            xFname$ = Dir(xDirect$, 7)

            Do While xFname$ <> ""
                ActiveCell.Offset(xRow) = xFname$
                xRow = xRow + 1
                xFname$ = Dir
            Loop

        End If

    End With

End Sub

Answer 1

Caveats:

1) I am not entirely clear on how you data etc is laid out so i am offering a way of achieving your goal that involves the elements i am clear on.

2) To be honest, personally, i would do as much using arrays or a dictionary as possible rather than going backwards and forwards to worksheets.

However...

Following the outline of your requirements and a little rough and ready, we have:

1) Using your macro rename (renamed as ListFiles and with a few minor tweaks) to write the chosen folder name out to Range("A1") in Worksheets("Batch Rename of Files") and the file names to Column C.

2) Using a second macro RenameFiles to pick up the rename shell commands from Column F of Worksheets("Batch Rename of Files"); write these out to a batch file on the desktop; add an additional first line command that sets the working directory to the chosen folder given in Range("A1") (Requirement A). The shell command executes the .bat file, completes the renaming (Requirement B) and then there is a line to remove the .bat file.

I am guessing this is a more efficient way of achieving your goal than looping the column F range executing a command one at a time.

I have not sought to optimize code in any further ways (i have added a few existing typed functions.) There are a number of other improvements that could be made but this was intended to help you achieve your requirements.

Let me know how it goes!

Tab1 layout (Sheet containing new file names):

Batch Rename of Files layout (Sheet containing output of the first macro and the buttons ):

Layout of Worksheet Batch Rename of File

In a standard module called ListFiles:

Option Explicit

Public Sub ListFilesInDirectory()

    Dim xRow As Long
    Dim xDirect$, xFname$, InitialFoldr$ 'type hints not really needed
    Dim wb As Workbook
    Dim wsTab2 As Worksheet

    Set wb = ThisWorkbook
    Set wsTab2 = wb.Worksheets("Batch Rename of Files")

    InitialFoldr$ = "C:\"

    Dim lastRow As Long
    lastRow = wsTab2.Cells(wsTab2.Rows.Count, "C").End(xlUp).Row

    wsTab2.Range("C4:C" & lastRow).ClearContents 'Get rid of any existing file names

    wsTab2.Range("C4").Activate

    With Application.FileDialog(msoFileDialogFolderPicker)

        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Please select a folder to list Files from"
        .InitialFileName = InitialFoldr$
        .Show

        If .SelectedItems.Count <> 0 Then

            xDirect$ = .SelectedItems(1) & "\"
            xFname$ = Dir(xDirect$, 7)
            wsTab2.Range("A1") = xDirect$

            Do While xFname$ <> vbNullString
                ActiveCell.Offset(xRow) = xFname$
                xRow = xRow + 1
                xFname$ = Dir
            Loop

        End If

    End With

End Sub

In a standard module called FileRenaming:

Option Explicit

Sub RenameFiles()

    Dim fso As New FileSystemObject
    Dim stream As TextStream
    Dim strFile As String
    Dim strPath As String
    Dim strData As Range
    Dim wb As Workbook
    Dim wsTab2 As Worksheet
    Dim currRow As Range

    Set wb = ThisWorkbook
    Set wsTab2 = wb.Worksheets("Batch Rename of Files")

    strPath = wsTab2.Range("A1").Value2

    If strPath = vbNullString Then

        MsgBox "Please ensure that Worksheet Batch Rename of Files has a directory path in cell A1"

    Else

        If Right$(Trim$(strPath), 1) <> "\" Then strPath = strPath & "\"

        strFile = "Rename.bat"

        Dim testString As String
        Dim deskTopPath As String
        deskTopPath = Environ$("USERPROFILE") & "\Desktop" 'get desktop path as this is where .bat file will temporarily be saved

        testString = fso.BuildPath(deskTopPath, strFile) 'Check if .bat already exists and delete

        If Len(Dir(testString)) <> 0 Then 
            SetAttr testString, vbNormal
            Kill testString
        End If

        Set stream = fso.CreateTextFile(deskTopPath & "\" & strFile, True) 'create the .bat file

        Dim lastRow As Long
        lastRow = wsTab2.Cells(wsTab2.Rows.Count, "C").End(xlUp).Row

        Set strData = wsTab2.Range("F4:F" & lastRow) 'Only execute for as many new file names as present in Col C (in place of your until blank requirement)

        stream.Write "CD /D " & strPath & vbCrLf

        For Each currRow In strData.Rows 'populate the .dat file
            stream.Write currRow.Value & vbCrLf
        Next currRow

        stream.Close

        Call Shell(testString, vbNormalFocus)

        Application.Wait (Now + TimeValue("0:00:01"))  'As sometime re-naming doesn't seem to happen without a pause before removing .bat file

        Kill testString

        MsgBox ("Renaming Complete")
    End If
End Sub

Buttons code in Worksheet Batch Rename of Files

Private Sub CommandButton1_Click()

    ListFilesInDirectory

End Sub

Private Sub CommandButton2_Click()
    RenameFiles
End Sub

Example .bat file contents:

VERSION 2

And here is a different version using a dictionary and passing parameters from one sub to another. This would therefore be a macro associated with only one button push operation i.e. there wouldn't be a second button. The single button would call ListFiles which in turn calls the second macro. May require you to go in to tools > references and add in Microsoft Scripting Runtime reference.

Assumes you have a matching number of new file names in Col D of tab 1 as the number of files found in the folder (as per your script to obtain files in folder). I have removed the obsolete type references.Shout out to the RubberDuck VBA add-in crew for the add-in picking these up.

In one standard module:

Option Explicit

Public Sub ListFiles()

    Dim xDirect As String, xFname As String, InitialFoldr As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim dict As New Scripting.Dictionary
    Dim counter As Long

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Tab1") 'Worksheet where new file names are

    counter = 4 'row where new file names start

    InitialFoldr = "C:\"

    With Application.FileDialog(msoFileDialogFolderPicker)

        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Please select a folder to list Files from"
        .InitialFileName = InitialFoldr
        .Show

        If .SelectedItems.Count <> 0 Then

            xDirect = .SelectedItems(1) & "\"
            xFname = Dir(xDirect, 7)

            Do While xFname <> vbNullString

              If Not dict.Exists(xFname) Then
                  dict.Add xFname, ws.Cells(counter, "D")  'Or which ever column holds new file names. This add to the dictionary the current name and new name
                  counter = counter + 1
                  xFname = Dir
              End If
            Loop

        End If

    End With

    RenameFiles xDirect, dict 'pass directory path and dictionary to renaming sub

End Sub

In another standard module:

Public Sub RenameFiles(ByVal folderpath As String, ByRef dict As Dictionary)

    Dim fso As New FileSystemObject
    Dim stream As TextStream
    Dim strFile As String
    Dim testString As String
    Dim deskTopPath As String

    strFile = "Rename.bat"
    deskTopPath = Environ$("USERPROFILE") & "\Desktop"
    testString = fso.BuildPath(deskTopPath, strFile)

    'See if .dat file of same name already on desktop and delete (you could overwrite!)
    If Len(Dir(testString)) <> 0 Then
        SetAttr testString, vbNormal
        Kill testString
    End If

    Set stream = fso.CreateTextFile(testString, True)

    stream.Write "CD /D " & folderpath & vbCrLf

    Dim key As Variant

    For Each key In dict.Keys
        stream.Write "Rename " & folderpath & key & " " & dict(key) & vbCrLf 'write out the command instructions to the .dat file
    Next key

    stream.Close

    Call Shell(testString, vbNormalFocus)

    Application.Wait (Now + TimeValue("0:00:01"))  'As sometime re-naming doesn't seem to happen without a pause before removing .bat file

    Kill testString

   ' MsgBox ("Renaming Complete")

End Sub

Scripting run time reference:

Adding runtime reference

Additional method for finding the desktop path. Taken from Allen Wyatt:

In a standard module add the following:

Public Function GetDesktop() As String
    Dim oWSHShell As Object

    Set oWSHShell = CreateObject("WScript.Shell")
    GetDesktop = oWSHShell.SpecialFolders("Desktop")
    Set oWSHShell = Nothing
End Function

Then in the rest of the code replace any instances of deskTopPath =..... e.g.:

deskTopPath = Environ$("USERPROFILE") & "\Desktop"

With

desktopPath = GetDesktop