Dim wbname As String
Dim filePATH As String
Dim datefrom As String
Dim dateto As String
Dim fDialog As FileDialog

    If ActiveDocument.path = "" Then
        Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
        With fDialog
            .Title = "Select folder to save the document"
            .AllowMultiSelect = False
            .InitialView = msoFileDialogViewList
            If .Show <> -1 Then
                filePATH = ""
            Else
                filePATH = fDialog.SelectedItems.Item(1) & Chr(92)
            End If
        End With
    Else
        filePATH = ActiveDocument.path
    End If
    If filePATH = "" Then
        MsgBox "No folder selected", vbCritical
        Exit Sub
    End If

    ' Selection.Find.ClearFormatting
    Selection.HomeKey wdStory
    With Selection.Find
        .Text = "????.??.??"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute
    datefrom = Selection.Text
    If Len(datefrom) < 8 Then
        MsgBox "Date From - not found", vbCritical
        Exit Sub
    End If
    datefrom = Right(datefrom, 8)
    Selection.Collapse 0
    Selection.Find.Execute
    dateto = Selection.Text
    If Len(dateto) < 8 Then
        MsgBox "Date To - not found", vbCritical
        Exit Sub
    End If
    dateto = Right(dateto, 8)
    wbname = datefrom & "-" & dateto

    ActiveDocument.SaveAs FileName:=filePATH & wbname & ".doc", FileFormat:= _
                          wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _
                          True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _
                          False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
                          SaveAsAOCELetter:=False