Your code is not copy/paste.
try this
Sub Button1_Click()
Dim sh As Worksheet
Dim rng As Range, pRng As Range
Set sh = Sheets("DP")
With sh
Set pRng = .Range("K" & .Cells(.Rows.Count, "K").End(xlUp).Row)
End With
Set rng = Sheets("Training").Range("B8:B23")
rng.SpecialCells(xlCellTypeConstants).Copy pRng
End SubMight be worth just using a new sheet
What is the code that is not working for you?
You may have to loop through the range to create the to list
Option Explicit
Sub EmailandSaveCellValue()
'Variable declaration
Dim oApp As Object, _
oMail As Object, _
WB As Workbook, _
FileName As String, MailSub As String, MailTxt As String
Dim Sdate As String
Dim MailTo As String
'-----------------------Creatte Email List---------------
Dim sh As Worksheet, rng As Range, c As Range, s As String
Set sh = Sheets("Data")
s = ""
With sh
Set rng = .Range("B2:B42,D2:D42").SpecialCells(xlCellTypeConstants, 23)
For Each c In rng.Cells
s = s & c & ";"
Next c
End With
s = Left(s, Len(s) - 1)
'--------------------End Email List-----------------------
'************************************************* ********
'Set email details; Comment out if not required
MailTo = s
Const MailCC = "some2@someone.com"
Const MailBCC = "some3@someone.com"
MailSub = "Please review " '& Range("Subject")
MailTxt = "I have attached " '& Range("Subject")
'************************************************* ********
'Turns off screen updating
Application.ScreenUpdating = False
'Makes a copy of the active sheet and save it to
'a temporary file
'ActiveSheet.Copy
Worksheets("Schedule").Copy
Set WB = ActiveWorkbook
Sdate = " - " & Format(Date, "yyyy")
FileName = " Training Calendar" & Sdate & ".xlsx"
On Error Resume Next
'Kill "D:\" & FileName
On Error GoTo 0
WB.SaveAs FileName:="D:\" & FileName
'Creates and shows the outlook mail item
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)
With oMail
.To = MailTo
.Cc = MailCC
.Bcc = MailBCC
.Subject = MailSub
.Body = MailTxt
.Attachments.Add WB.FullName
.Display
End With
'Deletes the temporary file
WB.ChangeFileAccess Mode:=xlReadOnly
Kill WB.FullName
WB.Close SaveChanges:=False
'Restores screen updating and release Outlook
Application.ScreenUpdating = True
Set oMail = Nothing
Set oApp = Nothing
End SubJust a quick observation,
You can delete the cells from the copied workbook.
After sheets.copy that new workbook is the active workbook, so
for example:
activeworkbook.sheets(sheetName).range("A1:B1").clearcontents
You can do all this before activeworkbook.saveas
HA!, Darn is short for darn-it!
Darn, will have to look closer at this
This will go in the command button
Private Sub CommandButton1_Click()
Dim actWsh As String, sh As Worksheet, ws As Worksheet
Set ws = Sheets("Schedule")
actWsh = ComboBox2.Text
Set sh = Sheets(actWsh)
With sh
.Range("A1").AutoFilter Field:=5, Criteria1:=Me.ComboBox3
.Range("A2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy ws.Cells(ws.Rows.Count, "B").End(xlUp).Offset(2)
End With
Unload Me
End SubI didn't merge the cells in column A
No error trapings
The file needs to be converted to xlsx, because the receiver will probably not have Macros activated.
Macros do not need to be activated in order to look at the workbook
I believe the problem is saving this workbook as a .xlsx file because it is a .xlsm file.
I do see that you have considered SaveCopyAs and noticed you can't change the file extension to .xlsx
Here is a consideration.
Save a copy to the temp folder, open that copy and saveas a .xlsx workbook to the desired location.
See this sample
Sub CreatCpyFoEmail()
Dim CPywb As Workbook, wb As Workbook
Dim FileNm As String, FilePath As String
Dim AtchFile As String
Application.ScreenUpdating = False
Set wb = ThisWorkbook
FilePath = "C:\TestFolder" & "\"
wb.SaveCopyAs Environ("Temp") & "\copy" & wb.Name
Set CPywb = Workbooks.Open(Environ("Temp") & "\copy" & wb.Name)
With CPywb
Application.DisplayAlerts = False
FileName = Left(wb.Name, Len(wb.Name) - 5)
AtchFile = FilePath & FileName & "-" & Format(Date, "ddmmyyy") & ".xlsx"
.SaveAs AtchFile, 51
.Close
Kill (Environ("Temp") & "\copy" & wb.Name)
End With
Application.ScreenUpdating = False
End SubPlease don't take this the wrong way Uncle Stringer...If I jump back and forth that would be counter productive and rude.
Pretty sure davesexcel was quoting you, I really doubt you offended him.
Were you able to experiment with the code I provided, explain how it doesn't work for you so we can help.
Learning how to step through a code is important as well, when you step through the code you will see what is happening and then you will know where the problem is.
Did you read post #8?
Might be best to create another variable string with the complete workbook name instead of confusing everything.
Check out this code sample.
Sub Button2_Click()
Dim wb As Workbook, sh As Worksheet
Dim WBpth As String
Dim FilePath As String
Dim FileName As String
Dim AtchFile As String
Set wb = ActiveWorkbook
Set sh = wb.Sheets("Sheet1")
Application.DisplayAlerts = False
With sh
FilePath = wb.Path & "\"
FileName = Left(wb.Name, Len(wb.Name) - 5)
AtchFile = FilePath & FileName & "-" & Format(Date, "ddmmyyy") & ".xlsx"
ActiveWorkbook.SaveAs AtchFile, 51
End With
MsgBox AtchFile & " is the file to attach"
End SubYou can search for both strings in the worksheet name
Private Sub ShowSelSheets()
Dim ws As Worksheet
Dim strType As String
Dim a As String, b As String
a = Range("Blocks").Value
b = Range("WorkoutTypes").Value
For Each ws In ActiveWorkbook.Sheets
If InStr(ws.Name, a) <> 0 And InStr(ws.Name, b) <> 0 Then
ws.Visible = xlSheetVisible
ws.Activate
Else
If ws.Name <> "Sheet1" Then
ws.Visible = xlSheetHidden
End If
End If
Next ws
End SubAttach a sample workbook
Just an observation, the column Count will always be 1+1 in row 1 as there is no data in the first few rows.