将日期选择器的VBA代码从原始工作表复制到复制的工作簿

Question

I hope you can help. I have a piece of code. Essentially what it does is, it opens a dialog box that allows a user to select an excel sheet, then it goes out to the country column (11) filters it, then copies and pastes that country into a new workbook, names the new workbook after that country then repeats the action for the next country, then it saves and closes each Workbook.

It also emails the workbook

My issue is this;

I have a date picker in Column P on the original workbook and it works perfectly. See Picture 1.

But the date picker code is not in a module it is on the Original Workbook in a sheet called "Template" See picture 2.

What I would like to happen is when the code runs for the filtering and copying and pasting of countries is for the Date Picker to be available in the copied workbooks. Is this possible? at the moment it just remains in the original.

Pic 1

Pic 2

Pic 3 Copied Workbooks form Original based on Column 11 saved in a different location

Pic 4 Copied Workbook No Date Picker

As always any help would be greatly appreciated My Code is below

Date Picker Code

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
     'check cells for desired format to trigger the calendarfrm.show routine
     'otherwise exit the sub
    Dim DateFormats, DF
    DateFormats = Array("m/d/yy;@", "mm/dd/yyyy")
    For Each DF In DateFormats
        If DF = Target.NumberFormat Then
            If CalendarFrm.HelpLabel.Caption <> "" Then
                CalendarFrm.Height = 191 + CalendarFrm.HelpLabel.Height
            Else: CalendarFrm.Height = 191
                CalendarFrm.Show
            End If
        End If
    Next
End Sub

The Large piece of code that filters, copies, pastes, formats and emails

Sub Open_Workbook_Dialog()

Dim my_FileName As Variant
Dim my_Workbook As Workbook

  MsgBox "Pick your CRO file" '<--| txt box for prompt to pick a file

  my_FileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*") '<--| Opens the file window to allow selection

  If my_FileName <> False Then
    Set my_Workbook = Workbooks.Open(Filename:=my_FileName)

    Call TestThis '<--|Calls the code that highlights blank cell in A,B and C yellow

    Call Worksheet_Change '<--|Calls the code that highlights duplicate values in column X

    Call Filter(my_Workbook) '<--|Calls the Filter Code and executes

  End If
End Sub

Public Sub Filter(my_Workbook As Workbook)
  Dim rCountry As Range, helpCol As Range
  Dim wb As Workbook
  Dim ws As Worksheet
  With my_Workbook.Sheets(1) '<--| refer to data worksheet
    With .UsedRange
      Set helpCol = .Resize(1, 1).Offset(, .Columns.Count) '<--| get a "helper" column just at the right of used range, it'll be used to store unique country names in
    End With

   With .Range("A1:Y" & .Cells(.Rows.Count, 1).End(xlUp).Row) '<--| refer to its columns "A:Y" from row 1 to last non empty row of column "A"
            .Columns(11).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=helpCol, Unique:=True '<-- call AdvancedFilter on 11th column of the referenced range and store its unique values in "helper" column
            Set helpCol = Range(helpCol.Offset(1), helpCol.End(xlDown)) '<--| set range with unique names in (skip header row)
            For Each rCountry In helpCol '<--| iterate over unique country names range (skip header row)
                .AutoFilter 11, rCountry.Value2 '<--| filter data on country field (11th column) with current unique country name
                If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then '<--| if any cell other than header ones has been filtered...
                    Set wb = Application.Workbooks.Add '<--... add new Workbook
                        wb.SaveAs Filename:="C:\Users\CONNELLP\Desktop\Claire Macro\CRO Countries\" & rCountry.Value2 '<--... saves the workbook after the country
                            .SpecialCells(xlCellTypeVisible).Copy wb.Sheets(1).Range("A1")
                               ActiveSheet.Name = rCountry.Value2  '<--... rename it
                           .SpecialCells(xlCellTypeVisible).Copy ActiveSheet.Range("A1") 'copy data for country under header
                           Sheets(1).Range("A1:Y1").WrapText = False 'Takes the wrap text off
                           ActiveWindow.Zoom = 55 'Zooms out the window
                         Sheets(1).UsedRange.Columns.AutoFit 'Autofits the column
                    ActiveWorkbook.Save '<--... saves and closes workbook
                    If ActiveSheet.Name = "Belgium" Then '<--... sends email to certain email based on active worksheet name
                    Call Mail_workbook_Outlook_1 '<--... calls the email sub routine
                    End If
                    If ActiveSheet.Name = "Bulgaria" Then
                    Call Mail_workbook_Outlook_2
                    End If
                    If ActiveSheet.Name = "Croatia" Then
                    Call Mail_workbook_Outlook_3
                    End If
                    If ActiveSheet.Name = "Czech Republic" Then
                    Call Mail_workbook_Outlook_1
                    End If
                    'ElseIf ActiveSheet.Name <> "Belgium" Then
                    'Call Mail_workbook_Outlook_2
                    'End If
                    wb.Close SaveChanges:=True '<--... saves and closes workbook
                End If
            Next
        End With
        .AutoFilterMode = False '<--| remove autofilter and show all rows back
    End With
    helpCol.Offset(-1).End(xlDown).Clear '<--| clear helper column (header included)
End Sub

Public Sub TestThis()
Dim wks As Worksheet

Set wks = ActiveWorkbook.Sheets(1)

With wks
.AutoFilterMode = False
.Range("A:K").AutoFilter Field:=11, Criteria1:="<>", Operator:=xlFilterValues
.Range("A:C").SpecialCells(xlCellTypeBlanks).Interior.Color = 65535
.AutoFilterMode = False
End With
End Sub

Public Sub Mail_workbook_Outlook_1()
'Working in Excel 2000-2016
'This example send the last saved version of the Activeworkbook
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .to = "philip.connell@merck.com"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .Body = "This should work for Belgium and Czech Republic"
        .Attachments.Add ActiveWorkbook.FullName
        'You can add other files also like this
        '.Attachments.Add ("C:\test.txt")
        .Send   'or use .Display
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Public Sub Mail_workbook_Outlook_2()
'Working in Excel 2000-2016
'This example send the last saved version of the Activeworkbook
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .to = "Philip.Connell@merck.com"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .Body = "Bulgaria"
        .Attachments.Add ActiveWorkbook.FullName
        'You can add other files also like this
        '.Attachments.Add ("C:\test.txt")
        .Send   'or use .Display
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
Public Sub Mail_workbook_Outlook_3()
'Working in Excel 2000-2016
'This example send the last saved version of the Activeworkbook
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .to = "Philip.Connell@merck.com"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .Body = "Croatia Only"
        .Attachments.Add ActiveWorkbook.FullName
        'You can add other files also like this
        '.Attachments.Add ("C:\test.txt")
        .Send   'or use .Display
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
Public Sub Worksheet_Change()
'If Target.Row = 1 Then Exit Sub             ' IF ITS A HEADER, DO NOTHING.

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False

    Dim myDataRng As Range
    Dim cell As Range

    ' WE WILL SET THE RANGE (SECOND COLUMN).
    Set myDataRng = Range("X1:X" & Cells(Rows.Count, "X").End(xlUp).Row)

    For Each cell In myDataRng
        cell.Offset(0, 0).Font.Color = vbBlack          ' DEFAULT COLOR.

        ' LOCATE DUPLICATE VALUE(S) IN THE SPECIFIED RANGE OF DATA.
        If Application.Evaluate("COUNTIF(" & myDataRng.Address & "," & cell.Address & ")") > 1 Then
            cell.Offset(0, 0).Font.Color = vbRed        ' CHANGE FORE COLOR TO RED.
        End If
    Next cell

    Set myDataRng = Nothing
ErrHandler:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Answer 1

I think the problem is in this line of code:

wb.SaveAs Filename:="C:\Users\CONNELLP\Desktop\Claire Macro\CRO Countries\" & rCountry.Value2 '<--... saves the workbook after the country

This saves the file in a standard format, xlsx. Which means no macros.
If you try to replace it with this:

wb.SaveAs Filename:="C:\Users\CONNELLP\Desktop\Claire Macro\CRO Countries\" & rCountry.Value2, fileformat:=52 

Then the files should be in xlsm in the folder.

EDIT: Now I noticed that you wrote that the macro opens a new workbook that it copies the data to.
That probably means that the fileformat is not the problem.
Is there any way that you can change the macro to copy "itself" and then edit the copied version to whatever you need?
I think, while your solution is correct for just data, but with passing along vba it makes it harder.

I recommend that you try to copy the master workbook instead of opening a new one.