VBA code is not working well to copy and paste across multiple workbooks

Question

In an attempt to automate my work, I am trying to generate personalised marksheets with name of student and marker in there as well as a save the workbook as"Student_Marker_Course" (for each student and marker), I have just picked up VBA last week and last time I tried to code something, it was in Java 10 years ago.

The code that I used below works, however, I don't think it is optimised as it does take a little while to generate the 100+ marksheets, I was just wondering if I did it well and where I could try to optimise it, Thanks!

Sub Marksheet()
    Dim x As Integer
    Dim Wbk1 As Workbook, Wbk2 As Workbook
    Dim Filename As String, Course As String

    Set Wbk1 = ThisWorkbook
    LRsource = Wbk1.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row ' find the final row

    For x = 2 To LRsource
        Filename = Cells(x, "T")
        Course = Cells(x, "G")
        'Below will find out which course the student is on and which marksheet to select

        If Course = "Course1" Then
            Set Wbk2 = Workbooks.Open("C:\Users\XXX\Desktop\Test\Course1.xlsx")  'Select Marksheet
           'Below will copy and paste the student name
            Wbk1.Sheets(1).Activate
            Cells(x, "E").Copy
            Wbk2.Activate
            Sheets(1).Cells(5, "C").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False

            'Below will copy and paste the Markers name
            Wbk1.Sheets(1).Activate
            Cells(x, "Q").Copy
            Wbk2.Activate
            Sheets(1).Cells(7, "C").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False

            Wbk2.SaveAs "Course1_Location\" & Filename & " .xlsx" 'Select destination
            Wbk2.Close
            Application.CutCopyMode = False
        ElseIf Course = "Course2" Then
            Set Wbk2 = Workbooks.Open("C:\Users\XXX\Desktop\Test\Course2.xlsx")  'Select Marksheet
           'Below will copy and paste the student name
            Wbk1.Sheets(1).Activate
            Cells(x, "E").Copy
            Wbk2.Activate
            Sheets(1).Cells(5, "C").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False

            'Below will copy and paste the Markers name
            Wbk1.Sheets(1).Activate
            Cells(x, "Q").Copy
            Wbk2.Activate
            Sheets(1).Cells(7, "C").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False

            'Finding where to save it
            Wbk2.SaveAs "Course2_Location\" & Filename & " .xlsx" 'Select destination
            Wbk2.Close
            Application.CutCopyMode = False
        Else
            Set Wbk2 = Workbooks.Open("C:\Users\XXX\Desktop\Test\Course3_6.xlsx")  'Select Marksheet

            'Below will copy and paste the student name
            Wbk1.Sheets(1).Activate
            Cells(x, "E").Copy
            Wbk2.Activate
            Sheets(1).Cells(5, "C").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False

            'Below will copy and paste the Markers name
            Wbk1.Sheets(1).Activate
            Cells(x, "Q").Copy
            Wbk2.Activate
            Sheets(1).Cells(7, "C").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False

            'Below will copy and paste the course name
            Wbk1.Sheets(1).Activate
            Cells(x, "G").Copy
            Wbk2.Activate
            Sheets(1).Cells(3, "D").Select
            ActiveSheet.Paste

            'Finding where to save it, I have multiple courses here, hence the if 
            If Course = "Course3" Then
                Wbk2.SaveAs "Course3_Location\" & Filename & " .xlsx" 'Select destination
            End If

            'Repeat above If for each course
            Wbk2.SaveAs "course3_Location" & Filename & " .xlsx" 'Select destination
            Wbk2.Close
            Application.CutCopyMode = False
        End If
    Next x
End Sub

A major improvement you could make is to incorporate the lessons of [How to avoid using Select in Excel VBA](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba). — BigBen, Jun 05 '19 at 15:01
Awesome! Thank you so much for this, I will have a read through — Nahilis, Jun 11 '19 at 12:48

score 0 · Answer 1 · answered Jun 05 '19 at 15:13

Let's give this a shot - I've removed all the copying/pasting/activating and replaced it with fully qualified value exchanges. Additionally, turning .ScreenUpdating off might help. One note - I'm not sure what you're trying to do with the saving portion in your Else statement - is that a typo?

Option Explicit
Sub Marksheet()

    Dim x As Long
    Dim Wbk1 As Workbook, Wbk2 As Workbook
    Dim Filename As String, Course As String

    Set Wbk1 = ThisWorkbook
    LRsource = Wbk1.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row

    Application.ScreenUpdating = False

    For x = 2 To LRsource

        Filename = Cells(x, "T")
        Course = Cells(x, "G")

        If Course = "Course1" Then

            Set Wbk2 = Workbooks.Open("C:\Users\XXX\Desktop\Test\Course1.xlsx")

            Wbk2.Sheets(1).Cells(5, "C").Value = Wbk1.Sheets(1).Cells(x, "E").Value
            Wbk2.Sheets(1).Cells(7, "C").Value = Wbk1.Sheets(1).Cells(x, "Q").Value

            Wbk2.SaveAs "Course1_Location\" & Filename & " .xlsx"
            Wbk2.Close

        ElseIf Course = "Course2" Then

            Set Wbk2 = Workbooks.Open("C:\Users\XXX\Desktop\Test\Course2.xlsx")

            Wbk2.Sheets(1).Cells(5, "C").Value = Wbk1.Sheets(1).Cells(x, "E").Value
            Wbk2.Sheets(1).Cells(7, "C").Value = Wbk1.Sheets(1).Cells(x, "Q").Value

            Wbk2.SaveAs "Course2_Location\" & Filename & " .xlsx"
            Wbk2.Close

        Else

            Set Wbk2 = Workbooks.Open("C:\Users\XXX\Desktop\Test\Course3_6.xlsx")

            Wbk2.Sheets(1).Cells(5, "C").Value = Wbk1.Sheets(1).Cells(x, "E").Value
            Wbk2.Sheets(1).Cells(7, "C").Value = Wbk1.Sheets(1).Cells(x, "Q").Value
            Wbk2.Sheets(1).Cells(3, "D").Value = Wbk1.Sheets(1).Cells(x, "G").Value

            'What's going on here?
            If Course = "Course3" Then
                Wbk2.SaveAs "Course3_Location\" & Filename & " .xlsx"
            End If

            Wbk2.SaveAs "course3_Location" & Filename & " .xlsx"
            Wbk2.Close

        End If
    Next x

    Application.ScreenUpdating = True

End Sub

This is exactly what I tried to achieve! Thank you so much for your help! — Nahilis, Jun 11 '19 at 12:49

VBA code is not working well to copy and paste across multiple workbooks

1 Answers1