MACRO - save individual tabs from workbook in seperate files

[lschuckm]

I am trying to build a macro where I copy individual tabs from a workbook and save each tab in its own file in a folder named based on the value in cell H3. So far I have the below code but it is not working. Can someone help?? I've been trying this for a while and cant figure it out.

Thanks!!

Sub Macro()
Dim ws As Worksheet
Dim strFoldername As String
Set ws = ActiveSheet
Set strFoldername = Range("H3").Value
For Each ws In ThisWorkbook.Worksheets
ws.Copy
ChDir _
"K:\INVESTORS\" & strFoldername & "\2015"
ActiveWorkbook.SaveAs Filename:= _
"K:\PredFund\INVESTORS\" & strFoldername & "\2015\Q3 15.xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
Next ws
End Sub

 

[lschuckm]

Anyone??