title: VBA - Saving all worksheets as separate files with a file name based on a cell
body: <p>I've found code to save all the worksheets, and I've found code to save the file with a filename based on a cell, but I can't seem to get both to work at the same time.  Below is my entire macro - but the problem seems to stem from the last section: Sub(SheetSplit).  I've tried all sorts of methods I've found online, but I need this to happen with a relative path - as in the same folder in which the workbooks are.  The code is in a workbook called "Remit Macros.xls" and the multi-tabbed workbook I'm messing with is "RemitReport.xls" - what am I missing here?  I always get an error of "Method 'SaveAs' of object '_Workbook' failed.  What gives?  I included the rest of the code in case it helps.</p>
  
  <pre><code>Sub RemitTotal()
      '
      ' Highlights remit amounts great enough for additional approvals
      '
      Workbooks.Open (ThisWorkbook.Path &amp; "\RemitReport.xls")
      Windows("RemitReport.xls").Activate
  
      Dim i As Long
      For i = 1 To Worksheets.Count
          Sheets(i).Select
  
          BeginRow = 6
          EndRow = Range("A1000").End(xlUp).Row
          ChkCol = 18
  
          For RowCnt = BeginRow To EndRow - 9
              If Cells(RowCnt, ChkCol).Value &gt; 500000 Then
                  Range("R6:R1000").Select
                  With Selection.Interior
                      .ColorIndex = 6
                      .Pattern = xlSolid
                  End With
              End If
          Next RowCnt
      Next i
  
      Call DateMacro
  
  End Sub
  
  Sub DateMacro()
      '
      ' Highlights dates not in the current month, i.e. early or late payments
      '
      Windows("RemitReport.xls").Activate
  
      Dim i As Long
      For i = 1 To Worksheets.Count
          Sheets(i).Select
  
          BeginRow = 6
          EndRow = Range("A1000").End(xlUp).Row
          ChkCol = 6
  
          For RowCnt = BeginRow To EndRow - 9
              If IsDate(Cells(RowCnt, ChkCol)) And Month(Date) &lt;&gt; Month(Cells(RowCnt, ChkCol - 1).Value) Then
                  'date values no longer need to be updated monthly
                  Cells(RowCnt, ChkCol - 1).Select
                  With Selection.Interior
                  .ColorIndex = 10
                  .Pattern = xlSolid
                  End With
              End If
          Next RowCnt
  
          BeginRow = 6
          EndRow = Range("A1000").End(xlUp).Row
          ChkCol = 6
  
          For RowCnt = BeginRow To EndRow - 9
              If Cells(RowCnt, ChkCol).Value = Cells(RowCnt, ChkCol - 1) + 30 Then
                  Cells(RowCnt, ChkCol).Select
                  With Selection.Interior
                      .ColorIndex = 0
                      .Pattern = xlSolid
                  End With
              End If
          Next RowCnt
      Next i
  
      Call RemitNames
  
  End Sub
  
  Sub RemitNames()
      '
      'Adds lender remit name in the active worksheets in order to facilitate
      'saving each sheet under a different filename indicative of lender
      '
      Dim i As Long
      For i = 1 To Worksheets.Count
          Sheets(i).Select
  
          Range("A65536").End(xlUp).Select
          Selection.Copy
          Application.CutCopyMode = False
          Selection.Copy
          Range("D1").Select
          Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
          :=False, Transpose:=False
          Range("E1").Select
  
          ActiveCell.Formula = "=RIGHT(D1,LEN(D1)-FIND("": "",D1))"
          Range("F1").Formula = "=TRIM(E1)"
          Range("D3:S3").Select
          With Selection
              .HorizontalAlignment = xlCenter
              .VerticalAlignment = xlBottom
              .WrapText = False
              .Orientation = 0
              .AddIndent = False
              .IndentLevel = 0
              .ShrinkToFit = False
              .ReadingOrder = xlContext
              .MergeCells = False
          End With
          Selection.Merge
          Range("J1").Formula = "=INDEX('[Remit Macros.xls]Remit Codes'!$B1:$B999,MATCH(F1,'[Remit Macros.xls]Remit Codes'!$A1:$A999,0))"
          Range("J1").Select
          Selection.Copy
          Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
          :=False, Transpose:=False
          Range("D1:F1").Select
          Selection.ClearContents
          Range("J1").Select
  
      Next i
  
      Call SheetSplit
  
  End Sub
  
  Sub SheetSplit()
      '
      'Creates an individual workbook for each worksheet in the active workbook.
      '
      Dim wbDest As Workbook
      Dim wbSource As Workbook
      Dim sht As Object
      Dim strSavePath As String
      Dim sname As String
      Dim relativePath As String
  
      Set wbSource = ActiveWorkbook
  
      For Each sht In wbSource.Sheets
  
          sht.Copy
          Set wbDest = ActiveWorkbook
  
          sname = ThisWorkbook.ActiveSheet.Range("A1") &amp; ".xls"
          relativePath = Application.ActiveWorkbook.Path &amp; "\" &amp; sname
          Application.DisplayAlerts = False
          ActiveWorkbook.CheckCompatibility = False
          ActiveWorkbook.SaveAs FileName:=relativePath, FileFormat:=xlExcel8
          Application.DisplayAlerts = True
  
          Range("A1").Clear
  
      Next
  
      MsgBox "Done!"
  
  End Sub
  </code></pre>
  
  <p>Edit: After several of the suggestions I've been given, here is the last section of the code.  It still doesn't work, but I think it's getting closer.  I've also cleaned it up a little bit.</p>
  
  <pre><code>Sub SheetSplit()
  'Creates an individual workbook for each worksheet in the active workbook.
  Dim wbDest As Workbook
  Dim wbSource As Workbook
  Dim sht As Object
  Dim strSavePath As String
  Dim sname As String
  Dim origpath As String
  Dim relativePath As String
  Set wbSource = ActiveWorkbook
      origpath = wbSource.Path
      'relativePath = origpath &amp; "\" &amp; sname
      'sname = sht.Range("A1") &amp; ".xls"
          For Each sht In wbSource.Sheets
              sht.Copy
              Set wbDest = ActiveWorkbook
              sname = sht.Range("A1") &amp; ".xls"
              relativePath = origpath &amp; "\" &amp; sname
              'relativePath = Application.ActiveWorkbook.Path &amp; "\" &amp; sname
              Application.DisplayAlerts = False
              ActiveWorkbook.CheckCompatibility = False
              ActiveWorkbook.SaveAs Filename:=relativePath, FileFormat:=56
              Application.DisplayAlerts = True
  'Range("A1").Clear
  Next
  MsgBox "Done!"
  End Sub
  </code></pre>