Question

我希望你能提供帮助。我有一段代码。基本上它的作用是，它打开一个允许用户选择Excel工作表的对话框，然后它转到国家/地区列（11）过滤它，然后将该国家/地区复制并粘贴到新工作簿中，命名新工作簿在那个国家然后重复下一个国家的行动之后，它会保存并关闭每个工作簿。

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

我的问题是这个;

我在原始工作簿的P列中有一个日期选择器，它运行良好。见图1。

但日期选择器代码不在一个模块中，它位于原始工作簿的名为＆＃34;模板＆＃34;见图2.

我想要发生的是当代码运行以进行过滤和复制并粘贴国家时，日期选择器可以在复制的工作簿中使用。这可能吗？目前它只是保留在原版中。

图1

图2

图3复制的工作簿表格基于第11栏保存在其他位置的原件

图4 复制的工作簿没有日期选择器

一如既往，我们非常感谢任何帮助，我的代码在下面

日期选择代码

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 = "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

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

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

这会以标准格式xlsx保存文件。这意味着没有宏如果您尝试将其替换为：

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

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

编辑：现在我注意到你写了宏打开了一个新的工作簿，它将数据复制到。
这可能意味着fileformat不是问题有没有办法可以更改宏来复制＆＃34;本身＆＃34;然后将复制的版本编辑为您需要的任何内容？
我认为，虽然你的解决方案对于数据是正确的，但是通过传递vba会使其变得更难。

我建议您尝试复制主工作簿而不是打开新工作簿。

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

1 个答案: