将包含多于 X 行数据的工作表复制到另一个工作簿

Question

我在一个工作簿 (A) 中有 100 个工作表。我想将包含超过 35 行数据的工作表复制到工作簿 (B) 中。

我编写的代码复制了少于 35 行数据的工作表。

Sub Split_workbook()

Dim last_row as long  
Dim sh as worksheet   
For Each sh In Worksheets   
    last_row = cells(rows.count,"A").End(xlUp).Row    
    If last_row >= 35 Then   
        sh.Copy after:=workbooks("B.xlsx").Sheets(Workbooks("B.xlsx").Sheets.count)   
    End if   
    Workbooks("A.xlsx").activate  
Next sh

End Sub

Answer 1

复制工作表

• 从一个工作簿 (ThisWorkbook) 运行代码，将某些工作表从另一个打开的工作簿 (A.xlsx) 复制到另一个（第三个）打开的工作簿 (B.xlsx)。

守则

Option Explicit

Sub splitWorkbook()
    
    Const ProcName As String = "splitWorkbook"
    On Error GoTo clearError
    
    Const srLimit As Long = 35
    
    Dim swb As Workbook: Set swb = Workbooks("A.xlsx")
    Dim srCount As Long: srCount = swb.Worksheets(1).Rows.Count
    
    Dim dwb As Workbook: Set dwb = Workbooks("B.xlsx")
     
    Dim sws As Worksheet
    Dim sLastRow As Long
    Dim dCount As Long
    
    Application.ScreenUpdating = False
    
    For Each sws In swb.Worksheets
        sLastRow = sws.Cells(srCount, "A").End(xlUp).Row
        If sLastRow >= srLimit Then
            dCount = dCount + 1
            sws.Copy After:=dwb.Sheets(dwb.Sheets.Count)
        End If
    Next sws
    'swb.Close False
    'dwb.Close True
    
ProcExit:
    
    If Not Application.ScreenUpdating Then
        Application.ScreenUpdating = True
    End If
    
    Select Case dCount
    Case 0
        MsgBox "No worksheets copied.", vbExclamation, "Fail?"
    Case 1
        MsgBox "Copied 1 worksheet.", vbInformation, "Success"
    Case Else
        MsgBox "Copied " & dCount & " worksheets.", vbInformation, "Success"
    End Select
    
    Exit Sub

clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
End Sub