How to rename worksheets in serial order with pre-defined conditions

[ThrottleWorks]

What I am trying to achieve

* I have excel file with multiple sheets
* Number of sheets will vary with every file
* All the sheets are named as Sheet1, Sheet2, Sheet3 in serial order
* I have 4 key words, for example Porsche, Yamaha, Ducati, Honda
* Atleast one key word will be present in each worksheet
* Location of the keywork is not fix, so I do control F by vba to locate
* I will search the 1st keyword in sheet1 (going in serial order using For each loop)
* Find Porcshe, if found, activesheet will be named Sheet1
* Will move to next sheet, search Porsche, if found Sheet1 Copy1
* In this manner I will search all the sheets with key word Porsche
* Then I will move to next Key Word which is Ducati
* If found then Sheet2, Sheet2 Copy1, Sheet2 Copy2
* I will search all the 4 key words in this manner
* If key word is not found, I will not rename the sheet
* The purpose I am doing this is, I want to derive data from
* Sheet1 to Sheet4 (and their kids)
* If data is not present in Sheet1 then I will search it in Sheet1 Copy1
* These are 4 tables named as Sheet1, Sheet2, Sheet3, Sheet4
* So ideally table 1 will be sheet1 but if the table is split then it will be Sheet1 and sheet1 copy1

I am trying to write this code since last 2 days. But not able to complete.
I got confused with multiple dependent combinations I wrote.

Can anyone please help me in this.

 

[ThrottleWorks]

I do not have net access at home.
Will be able to reply on Monday for any help provided in between.

Thanks in advance.

 

[NARAYANK991]

Hi Sachin ,

See if this helps :

Public Sub Rename_Worksheets()
          Dim items As Variant
          Dim rng As Range
          Dim counter As Integer, i As Integer, j As Integer
          Dim curr_shtname As String, new_shtname As String
         
          items = Array("Porsche", "Yamaha", "Ducati", "Honda")
          For i = LBound(items) To UBound(items)
              searchitem = items(i)
              counter = 0
              For j = 1 To Worksheets.Count
                  Set rng = Worksheets(j).Cells.Find(searchitem)
                  If Not (rng Is Nothing) Then
                      If counter > 0 Then
                        new_shtname = curr_shtname & " Copy " & counter
                        Worksheets(j).Name = new_shtname
                      Else
                        curr_shtname = Worksheets(j).Name
                      End If
                      counter = counter + 1
                  End If
              Next
          Next
End Sub

Narayan

 

[ThrottleWorks]

Hi Narayna Sir, good evening.

Thanks a lot for the help. I read your reply on Saturday only. Could not reply from mobile.
I am checking your code, will share the results soon.

 

[ThrottleWorks]

Sir, it is working fine. Thanks a lot for your help and time.

P.S. - Wishing you and all the Forum members a very happy new year.
(today is first day of Marathi new year)

 

[Somendra Misra]

@ThrottleWorks

Nav varsha chi hardik subhecha bhau!!!!

Regards,

 

[rumshar]

FYI,
It is Telegu and Kannada new year too....
Rudra