I hope you can help. I have a code. Essentially, it opens a dialog box that allows the user to select an Excel sheet, then he goes to the village column (11), which filters it, then copies and pastes this country into a new workbook, calls a new workbook, after that the country repeats the action for the next country , then saves and closes each Workbook.
He also sends email to the book.
My problem is this:
I have a date picker in column P in the original book and it works great. See Figure 1.
But the date selection code is not in the module, which it is in the original book in the sheet called "Template". See figure 2.
What I would like to do is when the code is run to filter, copy and paste countries, so that the date picker is available in copied books. Is it possible? at the moment it just remains in the original.
Pic 1
Pic 2
Pic 3 Copied workbooks. Original based on column 11 stored elsewhere
Pic 4 Copied book No date picker
As always, any help would be greatly appreciated. My code is below
Date Selection 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
Most code that filters, copies, pastes, formats, and email
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