CODEWITHSUNDEEP
vbaexcel
Clauric
Clauric

Reputation: 1886

Rename multiple spreadsheets macro

I have an Excel VBA macro that takes in multiple text files (50+), and converts them into .xlsx spreadsheets. I would like to rename these according to the original name of the file.

I've tried to use the following code, but it would only work for 1 name.

    Sub Rename_Files()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.DisplayStatusBar = False

Dim k As Integer
Dim t As String
Dim x As Integer

k = Sheets.Count
x = 1

    While x <= k
        t = Sheets(x).Name
        If t = "validated_deals" Then

            Sheets(x).Name = "Clauric - Validated Deals"
            x = x + 1

        Else

            x = x + 1
        End If

    Wend

End Sub

Obviously I could redo the While loop for each name, but is there a quicker way to do it, using a loop. I have the names of all the files stored in a separate location, if that helps.

Upvotes: 0

Views: 88

Answers (1)

ManishChristian
ManishChristian

Reputation: 3784

Assuming you have your old sheet names in column A and new sheet names in column B on Sheet4, like this:

enter image description here

And here is the code: 

Sub Rename_Files()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.DisplayStatusBar = False

    Dim k As Integer
    Dim t As String
    Dim x As Integer
    Dim arrOldNames As Variant
    Dim arrNewNames As Variant

    'GETTING THE LAST ROW FROM SHEET4
    With Sheets("Sheet4")
        LRow = .Range("A" & .Rows.Count).End(xlUp).Row
    End With

    'ASSUMING COL-A HOLDS OLD SHEET NAMES AND COL-B HOLDS NEW SHEET NAMES ON SHEET4
    arrOldNames = Sheets("Sheet4").Range("A2:A" & LRow).Value
    arrNewNames = Sheets("Sheet4").Range("B2:B" & LRow).Value

    k = Sheets.Count
    x = 1

    While x <= k
        t = Sheets(x).Name
        x = x + 1

        'HERE WE'LL RUN A LOOP ON ALL THE NAMES AND CHANGE THE NAME IF MATCHES
        For i = 1 To UBound(arrOldNames)
            If arrOldNames(i, 1) = t Then
                Sheets(x - 1).Name = arrNewNames(i, 1)
                Exit For
            End If
        Next

    Wend

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.DisplayStatusBar = True

End Sub

This sub will create two arrays, one holding old names and another holding new names. It'll run a loop on each names and if name matches, it will changes the name.

-> Make sure you have same number of names (old and new).

Upvotes: 1

Related Questions