Conell8383
Board Regular
- Joined
- Jul 26, 2016
- Messages
- 66
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
The Large piece of code that filters, copies, pastes, formats and emails
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
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
Code:
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