20170906xlVBA_CopyDataAndFormatFromSheets

Posted 2020-10-05 Excel VBA 小天地

Public Sub GatherDataInSameWorkbook()
    AppSettings
    
    ‘ On Error GoTo ErrHandler
    
    Dim StartTime, UsedTime As Variant
    StartTime = VBA.Timer
    ‘>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    Dim wb As Workbook
    Dim Sht As Worksheet
    Dim Rng As Range
    Dim OneSht As Worksheet
    Dim SheetCount As Long
    Const SHEET_NAME As String = "总表"
    Const HEAD_ROW As Long = 1
    
    ‘>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    Set wb = Application.ThisWorkbook    ‘工作簿级别
    Set Sht = wb.Worksheets(SHEET_NAME)
    Sht.UsedRange.Offset(2).Clear
    
    For Each OneSht In wb.Worksheets
        If OneSht.Name Like "*系统" Then
            With OneSht
                EndRow = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row
                Set Rng = .Range("A3:Q" & EndRow)
                Debug.Print .Name; "  "; Rng.Address
                EndRow = Sht.Cells.Find("*", Sht.Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row + 1
                Rng.Copy Sht.Cells(EndRow, 1)
            End With
        End If
    Next
    
    ‘>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    UsedTime = VBA.Timer - StartTime
    Debug.Print "UsedTime ：" & Format(UsedTime, "#0.0000 Seconds")
    ‘MsgBox "UsedTime ：" & Format(UsedTime, "#0.0000 Seconds")
    
    
ErrorExit:
    Set wb = Nothing
    Set Sht = Nothing
    Set OneSht = Nothing
    Set Rng = Nothing
    AppSettings False
    Exit Sub
    ‘>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
ErrHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Description & "！", vbCritical, " QQ "
        ‘Debug.Print Err.Description
        Err.Clear
        Resume ErrorExit
    End If
End Sub
Public Sub AppSettings(Optional IsStart As Boolean = True)
    Application.ScreenUpdating = IIf(IsStart, False, True)
    Application.DisplayAlerts = IIf(IsStart, False, True)
    Application.Calculation = IIf(IsStart, xlCalculationManual, xlCalculationAutomatic)
    Application.StatusBar = IIf(IsStart, ">>>>>>>>Macro Is Running>>>>>>>>", False)
End Sub