Optimize VBA copy/paste

[Giulianeo]

Hey guys,

I am basically trying to make my code run faster, I am trying to convert a section of the code that copies and pastes data across two workbooks to be faster and cleaner.

Here is the original paste/copy data:

Sub WALLCERTIFICATE()'
' Macro2 Macro
'
Dim M As Workbook
Set M = ActiveWorkbook


' Copies / paste data from trainer scoresheet to digital certificate.
    Range("A1").Select
    Selection.Copy
    Workbooks.Open "V:\DEPARTMENTS\DRIVER TRAINING\COORDINATION\Scoresheets\Wall Certificate Macro\Digital Wall Certificate.xlsx"
    Windows("Digital Wall Certificate.xlsx").Activate
    Sheets("ColourFast").Select
    Range("A37").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    M.Activate
    Sheets("COURSE").Visible = True
    Sheets("Colourfast Printing").Visible = True
    Sheets("Student").Visible = True
    Sheets("Colourfast Printing").Select
    Range("A1:P33").Select
    Selection.Copy
    Windows("Digital Wall Certificate.xlsx").Activate
    Sheets("ColourFast").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

And here is the "cleaner" version

Sub WALLCERTIFICATE()'
' Macro2 Macro
'


Application.ScreenUpdating = False
Dim M As Workbook
Dim K As Workbook
Set M = ActiveWorkbook
Set K = Workbooks.Open("V:\DEPARTMENTS\DRIVER TRAINING\COORDINATION\Scoresheets\Wall Certificate Macro\Digital Wall Certificate.xlsx")


' Copies / paste data from trainer scoresheet to digital certificate.
    
    M.Activate
    Sheets("COURSE").Visible = True
    Sheets("Colourfast Printing").Visible = True
    Sheets("Student").Visible = True
    M.Sheets("Colourfast Printing").Range("A1").Value = K.Sheets("Colourfast").Range("A37").Value
    M.Sheets("Colourfast Printing").Range("A1:P33").Value = K.Sheets("Colourfast").Range("A1").Value

Of course it doesn't work at all, so would anybody be so kind as to help me figure out why?

Thank you!!!

 

[Fluff]

How about

    K.Sheets("Colourfast").Range("A37").Value = M.Sheets("Colourfast Printing").Range("A1").Value
    K.Sheets("Colourfast").Range("A1:P33").Value = M.Sheets("Colourfast Printing").Range("A1:P33").Value

 

[Giulianeo]

How about

    K.Sheets("Colourfast").Range("A37").Value = M.Sheets("Colourfast Printing").Range("A1").Value
    K.Sheets("Colourfast").Range("A1:P33").Value = M.Sheets("Colourfast Printing").Range("A1:P33").Value

Thank you for the response, however is that not what I have but with the workbooks order reversed? I need to copy data from workbook M to K. Although I did not try your line of code yet (not at work) I did experiment with the

.value =

and it was not working either... is what I am asking even possible?

Thank you!!!!

 

[Fluff]

is what I am asking even possible?

Yes, it's what my suggestion does.

 

[Giulianeo]

Yes, it's what my suggestion does.

Thank you! It works great... One more thing after I run the macro, it leaves open two grey windows which I assume come from the .close command which only closes the workbook and not the application, I would like to have one workbook remain open after running the macro but if I use application.quit everything goes... is there anyway around this?

Thank you again!!

 

[Fluff]

can you please post the complete code.

 

[Giulianeo]

can you please post the complete code.

There you go, thanks again.

Sub REDACTED()'
' Macro2 Macro
'


Application.ScreenUpdating = False
Dim M As Workbook
Dim K As Workbook
Set M = ActiveWorkbook
Set K = Workbooks.Open("V:\DEPARTMENTS\DRIVER TRAINING\COORDINATION\Scoresheets\Wall Certificate Macro\Digital Wall Certificate.xlsx")


' Copies / paste data from trainer scoresheet to digital certificate.
    
    M.Activate
    Sheets("COURSE").Visible = True
    Sheets("Colourfast Printing").Visible = True
    Sheets("Student").Visible = True
    K.Sheets("Colourfast").Range("A37").Value = M.Sheets("Trainer Score Sheet").Range("A1").Value
    K.Sheets("Colourfast").Range("A1:P33").Value = M.Sheets("Colourfast Printing").Range("A1:P33").Value
    
 'Sort empty cells
  K.Activate
  Range("D3:S22").Select
    Worksheets("ColourFast").Sort.SortFields.Clear
    Worksheets("ColourFast").Sort.SortFields.Add Key:=Range("D3") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("ColourFast").Sort
        .SetRange Range("D3:S22")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    
    
 'Export PDF Wall certificate / Close certificate workbook.
    K.Sheets("colourfast").Activate
    Dim rng As String
    rng = Range("AA3").Value
    Sheets(Array("Certificate")).Select
    On Error GoTo ErrorHandler
    Range(rng).ExportAsFixedFormat Type:=xlTypePDF, Filename:="V:\DEPARTMENTS\DRIVER TRAINING\COORDINATION\Scoresheets\Wall Certificate Macro\Digital Wall Certificate", openafterpublish:=False, ignoreprintareas:=False
    K.Close savechanges = False
    
    
    
    


    
   
    
    
    
    
    
    
  
  'Outlook macro is initialized.
    
  Dim IsCreated As Boolean
  Dim i As Long
  Dim PdfFile As String, Title As String
  Dim OutlApp As Object
  
  M.Activate
  Sheets("Trainer Score Sheet").Select
  ' Not sure for what the Title is
  Title = Range("A3")
 
  ' Define PDF filename
  PdfFile = ActiveWorkbook.FullName
  i = InStrRev(PdfFile, ".")
  If i > 1 Then PdfFile = Left(PdfFile, i - 1)
  PdfFile = PdfFile & "_" & ActiveSheet.Name & ".pdf"
 
  ' Export activesheet as PDF
  Sheets(Array("Trainer Score Sheet")).Select
  With ActiveSheet
    .ExportAsFixedFormat Type:=xlTypePDF, Filename:="V:\DEPARTMENTS\DRIVER TRAINING\COORDINATION\Scoresheets\Wall Certificate Macro\ScoreSheet.PDF", Quality:=xlQualityStandard, IncludeDocProperties:=True, ignoreprintareas:=False, openafterpublish:=False
  End With
 
  ' Use already open Outlook if possible
  On Error Resume Next
  Set OutlApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutlApp = CreateObject("Outlook.Application")
    IsCreated = True


  End If
  OutlApp.Visible = True
  On Error GoTo 0
 
  ' Prepare e-mail with PDF attachment
  With OutlApp.CreateItem(0)
    
  


    
   
    ' Prepare e-mail
    .Subject = Title
    .SentOnBehalfOfName = "REDACTED"
    .To = Range("AC3") ' <-- Put email of the recipient here
    .CC = "" ' <-- Put email of 'copy to' recipient here
    .Body = "Hello" & " " & Range("M3") & "!" & vbLf & vbLf _
            & "REDACTED:" & vbLf & vbLf _
            & "REDACTED" & vbLf _
            & "REDACTED" & vbLf & vbLf _
            & "REDACTED." & vbLf & vbLf _
            & "REDACTED " & vbLf & vbLf _
            & "REDACTED" & vbLf & vbLf _
            & "REDACTED" & vbLf & vbLf _
            & "REDACTED" & vbLf & vbLf


            
     
     strlocation = "V:\DEPARTMENTS\DRIVER TRAINING\COORDINATION\Scoresheets\Wall Certificate Macro\ScoreSheet.PDF"
    .Attachments.Add (strlocation)
     strlocation = "V:\DEPARTMENTS\DRIVER TRAINING\COORDINATION\Scoresheets\Wall Certificate Macro\Digital Wall Certificate.PDF"
    .Attachments.Add (strlocation)
    
    
    ' Try to send
    On Error Resume Next
    .Send
    Application.Visible = True
     If Err Then
      MsgBox "E-mail not sent, please ensure the email field is not empty and double check it for any spelling errors.", vbExclamation
    Else
      MsgBox "E-mail successfully sent.", vbInformation
    End If
    On Error GoTo 0
   
    End With
 
  ' Delete PDF file
  
 
  ' Quit Outlook if it was created by this code
  If IsCreated Then OutlApp.Quit
 
  ' Release the memory of object variable
  Set OutlApp = Nothing
  








Exit Sub
ErrorHandler:
    MsgBox "Please check you are using document version 1.3 or higher on the upper left corner of the trainer scoresheet tab."
K.Close savechanges = False
M.Sheets("Trainer Score Sheet").Select
Application.ScreenUpdating = True








End With
  






End Sub

 

[Fluff]

Are you sure that the two grey windows are Excel?
That code should close the "K" file without leaving anything.

 

[Giulianeo]

Are you sure that the two grey windows are Excel?
That code should close the "K" file without leaving anything.

Well it is interesting you mention that, because when the code skips towards the error handle sub at the end and it closes the K.worbook it doesn't leave anything behind, could this be related to Outlook objects?

Yes they are excel windows tho, 100% two of them that when I try to close them nothing happens only way to get rid of them is by closing all my opened excels workbooks and reopening the files again however this time they will open in those left over grey workbooks. Very strange indeed....

 

[Fluff]

have never encountered anything like and cannot see anything in the code that would cause the problem, so cannot help.