Sub test()
Dim i&, x&
Dim dicOb As Object, dicOb1 As Object
Dim book1 As Workbook, book2 As Workbook, sht1 As Worksheet
Dim arr1(), arr2$(), ikey, jkey

Application.ScreenUpdating = False
Set dicOb = CreateObject("Scripting.Dictionary")
Set dicOb1 = CreateObject("Scripting.Dictionary")
dicOb1.comparemode = 1
Set book1 = ThisWorkbook
With book1
    Set sht1 = .Sheets(1)
    With sht1
        i = .Cells(.Rows.Count, "g").End(xlUp).Row
        arr1 = .Range(.Range("b2"), .Range("g" & i))
        For i = LBound(arr1) To UBound(arr1)
            dicOb.Item(CStr(arr1(i, UBound(arr1, 2)))) = dicOb.Item(CStr(arr1(i, UBound(arr1, 2)))) & arr1(i, 2) & ","
        Next i
    End With
End With
For Each ikey In dicOb.keys
    x = 0
    arr2 = Split(Left(dicOb.Item(ikey), Len(dicOb.Item(ikey)) - 1), ",")
    dicOb1.RemoveAll
    For Each jkey In arr2
        dicOb1.Item(CStr(jkey)) = dicOb1.Item(CStr(jkey))
    Next jkey
    Set book2 = Workbooks.Open(Filename:=ikey)
    With book2
        Do Until .Sheets.Count >= dicOb1.Count
            .Sheets.Add
        Loop
        For Each jkey In dicOb1.keys
            x = x + 1
            .Sheets(x).Name = jkey
        Next jkey
        .Close True
    End With
Next ikey
Application.ScreenUpdating = True
End Sub

Public Sub www()
    Dim wb As Workbook, i&
    On Error Resume Next
    For i = 2 To 52
        If Cells(i, 2).Interior.ColorIndex = 6 Then
            Set wb = Workbooks.Open(Cells(i, 7).Value, False)
            wb.Sheets(Cells(i, 2).Value).Name Cells(i, 1).Value
            wb.Close -1: Set wb = Nothing
        End If
    Next
End Sub

Public Sub www()
    Dim wb As Workbook, i&
    On Error Resume Next
    For i = 2 To 52
        If Cells(i, 2).Interior.ColorIndex = 6 Then
            Set wb = Workbooks.Open(Cells(i, 7).Value, , False, , , , , , , True)
            For Each sh In wb.Worksheets
                sh(Cells(i, 2).Value).Name.Activate = Cells(i, 1).Value
            Next
            wb.Close 0
            End If
    Next
End Sub

Sub test()
Dim i&, j&, ikey
Dim dicOb As Object, dicOb1 As Object, sh As Worksheet
Dim book1 As Workbook, book2 As Workbook, sht1 As Worksheet

Application.ScreenUpdating = False
Set dicOb = CreateObject("Scripting.Dictionary")
Set dicOb1 = CreateObject("Scripting.Dictionary")

Set book1 = ThisWorkbook
With book1
    Set sht1 = .Sheets(1)
    With sht1
        j = .Cells(.Rows.Count, "g").End(xlUp).Row
        For i = 2 To j
            If .Range("a" & i) <> .Range("b" & i) Then
                dicOb.Item(CStr(.Range("g" & i))) = .Range("b" & i)
                dicOb1.Item(CStr(.Range("g" & i))) = .Range("a" & i)
            End If
        Next i
    End With
End With
For Each ikey In dicOb.keys
    Set book2 = Workbooks.Open(Filename:=ikey)
    With book2
        For Each sh In .Worksheets
            If sh.Name = dicOb.Item(ikey) Then sh.Name = dicOb1.Item(ikey)
        Next sh
        .Close True
    End With
Next ikey
Application.ScreenUpdating = True
End Sub

With book2
        For Each sh In .Worksheets
            If sh.Name = dicOb.Item(ikey) Then sh.Name = dicOb1.Item(ikey)
        Next sh
        .Close True
    End With