Save sheets named from cells that are in range. [VBA]

[fredhedge]

Hi pros

I have been fighting with this day trying different solutions. I have 40 rows in column C on page 1Date. If the cell matches a sheet name inside this workbook it should save that sheet as external separate workbook as the value in the cell. Currently getting 1004 error, object does not support this property or method.

Function WorksheetExists(sName As String) As Boolean
    WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End Function

Sub Saving()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim xRg As Range
Dim wSh As Worksheet
Dim wS As Worksheet
Dim wBk As Workbook
Dim xPath As String
Set wSh = ActiveWorkbook.Worksheets("1Date")
Set wBk = ActiveWorkbook


Quarter = ((Month(Date) + 2) \ 3) - 1
Year1 = Format(DateAdd("m", -1, Date), "yyyy")


xPath = Application.ActiveWorkbook.path


For Each xRg In wSh.Range("C2:C40")
[COLOR=#ff0000]    For Each wS In wBk[/COLOR]
    
            If WorksheetExists(xRg.Value) = True Then
            xRg = sName
            ActiveWorkbook.Worksheets(sName).Copy
            Application.ActiveWorkbook.SaveAs filename:=xPath & "\" & sName.Name & Space(1) & "q" & Quarter & Space(1) & Year1 & ".xlsx"
            Application.ActiveWorkbook.Close False
            Else
            End If
    Next wSh
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

 

[Fluff]

How about

For Each xRg In Wsh.Range("C2:C40")
   If WorksheetExists(xRg.Value) = True Then
      sname = xRg.Value
      wbk.Worksheets(sname).Copy
      Application.ActiveWorkbook.SaveAs filename:=XPath & "\" & sname & Space(1) & "q" & Quarter & Space(1) & Year1 & ".xlsx"
      Application.ActiveWorkbook.Close False
   End If
Next