Question

将工作簿添加到ActiveSheet.Paste中后，添加工作簿后的Module代码可以工作，但是如果我将其放置在Workbook AfterSave Event中，则会返回错误。当我尝试将Debug.Print(Application.ActiveSheet.Name) it prints Sheet1 and Debug.Print（Application.ActiveWorkbook.Name）用作Book13时，它应该是正确的。我还尝试放置Range("A1").Select，但它仍不能粘贴。

Private Sub Workbook_AfterSave(ByVal Success As Boolean)

'This section just counts total number of rows for worksheets    
Dim Total_rows_Entries As Long
Dim Total_rows_Payees As Long
Dim Total_rows_Accounts As Long

Workbooks("ONLINE-CASH VOUCHER.xlsm").Activate

With Worksheets("Entries").ListObjects("Entries").ListColumns(3).Range
Total_rows_Entries = .Find(What:="*", _
    After:=.Cells(1), _
    Lookat:=xlPart, _
    LookIn:=xlFormulas, _
    SearchOrder:=xlByRows, _
    SearchDirection:=xlPrevious, _
    MatchCase:=False).Row
End With

With Worksheets("List of Payees").ListObjects("ListofPayees").ListColumns(1).Range
Total_rows_Payees = .Find(What:="*", _
    After:=.Cells(1), _
    Lookat:=xlPart, _
    LookIn:=xlFormulas, _
    SearchOrder:=xlByRows, _
    SearchDirection:=xlPrevious, _
    MatchCase:=False).Row
End With

With Worksheets("List of Accounts").ListObjects("ListofAccounts").ListColumns(1).Range
Total_rows_Accounts = .Find(What:="*", _
    After:=.Cells(1), _
    Lookat:=xlPart, _
    LookIn:=xlFormulas, _
    SearchOrder:=xlByRows, _
    SearchDirection:=xlPrevious, _
    MatchCase:=False).Row
End With

'Problem is in this section    
Dim vArr As String
Dim lastColumn As Long
Dim wb As Workbook
Dim WS As Excel.Worksheet
Dim copy_Path As String
Dim open_wb As Boolean

copy_Path = "C:\Users\Asus\Desktop\"
For Each WS In Workbooks("ONLINE-CASH VOUCHER.xlsm").Worksheets
    If WS.Name = "Entries" Or WS.Name = "List of Accounts" Or WS.Name = "List of Payees" Then
        lastColumn = Worksheets(WS.Name).Cells(1, Columns.Count).End(xlToLeft).Column
        vArr = Split(Cells(1, lastColumn).Address(True, False), "$")(0)
        Worksheets(WS.Name).Range("A1:" & vArr & Total_rows_Entries).Copy
        Set wb = Workbooks.Add
        'Error is this ActiveSheet.Paste
        ActiveSheet.Paste
        Application.DisplayAlerts = False
        open_wb = IsWorkBookOpen(copy_Path & WS.Name & ".xlsx")
        If open_wb = True Then
            Workbooks(WS.Name & ".xlsx").Close
        End If
        wb.SaveAs copy_Path & WS.Name & ".xlsx"
        Application.DisplayAlerts = True
        ActiveWorkbook.Close
    End If
Next

End Sub

Answer 1

尝试这些修订。

Option Explicit

Private Sub Workbook_AfterSave(ByVal Success As Boolean)

    'This section just counts total number of rows for worksheets
    Dim Total_rows_Entries As Long
    Dim Total_rows_Payees As Long
    Dim Total_rows_Accounts As Long

    'With Workbooks("ONLINE-CASH VOUCHER.xlsm")
    With ThisWorkbook

        With .Worksheets("Entries").ListObjects("Entries").ListColumns(3).Range
            Total_rows_Entries = .Find(What:="*", _
                After:=.Cells(1), _
                Lookat:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row
        End With

        With .Worksheets("List of Payees").ListObjects("ListofPayees").ListColumns(1).Range
            Total_rows_Payees = .Find(What:="*", _
                After:=.Cells(1), _
                Lookat:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row
        End With

        With .Worksheets("List of Accounts").ListObjects("ListofAccounts").ListColumns(1).Range
            Total_rows_Accounts = .Find(What:="*", _
                After:=.Cells(1), _
                Lookat:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row
        End With

        Dim copy_Path As String
        Dim lastColumn As Long, total_Rows As Long
        Dim wb As Workbook, ws As Worksheet
        Dim open_wb As Boolean

        copy_Path = "C:\Users\Asus\Desktop\"

        For Each ws In .Worksheets
            With ws
                Select Case .Name
                    Case "Entries"
                        total_Rows = Total_rows_Entries
                    Case "List of Accounts"
                        total_Rows = Total_rows_Accounts
                    Case "List of Payees"
                        total_Rows = Total_rows_Payees
                End Select
                Select Case .Name
                    Case "Entries", "List of Accounts", "List of Payees"
                        On Error Resume Next
                        Workbooks(ws.Name & ".xlsx").Close savechanges:=False
                        Set wb = Workbooks.Add
                        On Error GoTo 0

                        lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
                        .Range(.Cells(1, "A"), .Cells(total_Rows, lastColumn)).Copy _
                            Destination:=wb.Worksheets(1).Cells(1, 1)
                        Application.DisplayAlerts = False
                        wb.SaveAs Filename:=copy_Path & ws.Name, FileFormat:=xlOpenXMLWorkbook
                        wb.Close savechanges:=False
                        Application.DisplayAlerts = True
                End Select
            End With
        Next

    End With

End Sub

ActiveSheet.Paste在工作簿事件中不起作用，但在模块中起作用

1 个答案: