Loop Thru Worksheet to move and save it as New Workbook

[lancerj017]

Guys I need help here :D can anyone check my code if i did something wrong? i can't figure it out

how to loop thru all worksheet and save it to a new workbook with the same path of original workbook.

here's my code:

Sub WorkbookSaveAs()
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim SourceWb As Workbook
    Dim DestWb As Workbook
    Dim FilePath As String
    Dim FileName As String
    Dim FolderPath As String
    Dim Current As Worksheet
    Dim WBName As String
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    FolderPath = Left(ActiveWorkbook.FullName, InStrRev(ActiveWorkbook.FullName, "\")) & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & " " & Format(Now, "yyyymmdd hh-mm-ss")
    MkDir FolderPath
    FilePath = FolderPath & "\"
    Set SourceWb = ActiveWorkbook
    Set DestWb = ActiveWorkbook
        FileName = Left(SourceWb.Name, Len(SourceWb.Name) - 4)
        Fileeextstr = ".xlsx"
        FileFormatNum = 51
    With DestWb
        .SaveAs FilePath & FileName & FileExtStr, FileFormat:=FileFormatNum
        For Each Current In .Worksheets
            WBName = Left(.Name, Len(.Name) - 5)
            If Current.Name <> WBName Or Left(Current.Name, Len(WBName)) <> WBName Then
                If .Sheets(Current.Name).Cells(Rows.Count, 1).End(xlUp).Row = 1 Then
                    Application.DisplayAlerts = False
                    Current.Delete
                    Application.DisplayAlerts = True
                Else
                    Current.Move
                    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Current.Name & ".xlsx"
                    ActiveWorkbook.Close savechanges:=False
                End If
            End If
        Next
    End With
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

 

[nuked]

What error are you getting?

 

[lancerj017]

no error but when my macro do the loop it won't work on creating workbook and save it to the same path of original workbook. can anyone may suggest a dynamic code that will move the worksheet and save it to the same location of original workbook?