Question

为了使我的工作自动化，我试图生成个性化的标记表，其中包含学生和标记的名称，并将工作簿另存为“ Student_Marker_Course”（针对每个学生和标记），我刚刚进行了选择VBA上周，也是我上次尝试编写代码的时间，那是10年前的Java。

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

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

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

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

1 个答案: