excel - VBA 代码无法很好地跨多个工作簿进行复制和粘贴

Question

为了使我的工作自动化，我正在尝试生成带有学生姓名和标记的个性化标记表，并将工作簿另存为“Student_Marker_Course”（针对每个学生和标记），我上周刚刚学习了 VBA上次我尝试编写代码时，还是 10 年前的 Java。

我在下面使用的代码有效，但是，我认为它没有经过优化，因为生成 100 多个标记表确实需要一些时间，我只是想知道我是否做得很好以及我可以在哪里尝试优化它，谢谢！

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

标签： excelvba

Answer 1

让我们试一试——我已经删除了所有的复制/粘贴/激活，并用完全合格的价值交换代替了它。此外，.ScreenUpdating关闭可能会有所帮助。一个注释-我不确定您要对Else语句中的保存部分做什么-这是一个错字吗？

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