将dateselect器的VBA代码从原始工作表复制到已复制的工作簿

我希望你能帮上忙。 我有一段代码。 实质上，它打开一个对话框，允许用户select一个Excel工作表，然后出口到国家栏（11）对其进行过滤，然后将该国家复制并粘贴到一个新的工作簿中，命名新的工作簿之后国家又重复下一个国家的行动，然后保存并closures每个工作簿。

它还通过电子邮件发送工作簿

我的问题是这个;

我在原始工作簿的P列中有一个dateselect器，它可以很好地工作。 见图1。

但date选取器代码不在模块中，而是位于名为“模板”的工作表中的原始工作簿中。请参见图2。

我想要发生的情况是代码运行过滤和复制和粘贴的国家是date选取器可在复制的工作簿。 这可能吗？ 目前它只是保留在原来的。

图1

图2

图3根据保存在不同位置的第11列的原始图像复制的工作簿表单

图4复制的工作簿没有dateselect器

与以往任何帮助将不胜感激我的代码如下

date选取器代码

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 

一大块过滤，复制，粘贴，格式化和电子邮件的代码

 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 = "[e-mail]" .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 = "[e-mail]" .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 = "[e-mail]" .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

我认为这个问题是在这行代码中：

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

这将以标准格式xlsx保存文件。 这意味着没有macros。
如果你试图用这个replace它：

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

然后文件应该在xlsm文件夹中。

编辑：现在我注意到，你写了macros打开一个新的工作簿，它将数据复制到。
这可能意味着文件格式不是问题。
有什么办法可以改变macros复制“本身”，然后编辑复制的版本到任何你需要的？
我认为，虽然你的解决scheme是正确的只是数据，但通过vba传递，这使得它更难。

我build议您尝试复制主工作簿而不是打开一个新的。