vba之小功能記錄--資料複製

編碼環境： office2010
背景環境：合同控制部實現簡單的資料複製。
程式程式碼:

Private Sub 複製()
Dim idate As String
''''''''獲取系統時間''''''''
idate = Date
'''''''''根據“合計”單元格的行數，得到最後一條資料所在的行數'''''''''
i = 1
Do
    If Sheets("***").Range("a" & i) = "合計" Then
    num = i - 1
    Exit Do
    End If
    i = i + 1
Loop
On Error Resume Next
    If ThisWorkbook.Worksheets("***1") Is Nothing Then    //判斷是否存在***1表
        '''''''''在檔案最後新增sheets'''''''''
        Sheets.Add AFTER:=Sheets(Sheets.Count)
        '''''''''sheets重新命名'''''''''
        ActiveSheet.Name = "***1"
        '''''''''資料複製'''''''''
        ThisWorkbook.Worksheets("***").Range("a1:p" & num).copy ThisWorkbook.Worksheets("***1").Range("a1:p" & num)
        '''''''''為每行資料後新增系統時間'''''''''
        For n = 4 To i
            If n = i Then
            Exit For
            Else: ThisWorkbook.Worksheets("***1").Range("p" & n).Value = idate
            End If
        Next n
        '''''修改單元格格式'''''
        Columns("P:P").ColumnWidth = 15.25
        '''''''''''刪除按鈕'''''''''''
        ActiveSheet.Shapes.Range(Array("Button 1")).Select
        Selection.Delete
        ActiveSheet.Shapes.Range(Array("Button 2")).Select
        Selection.Delete
    Else
        ''''''''''得到最後一行資料的所在行數''''''''''
        j = Sheets("***1").Range("a65536").End(xlUp).Row + 1
        ThisWorkbook.Worksheets("***").Range("a4:p" & num).copy ThisWorkbook.Worksheets("***1").Range("a" & j)
        Max = Sheets("***1").Range("a65536").End(xlUp).Row
        For m = j To Max
            If m = Max + 1 Then
            Exit For
            Else: ThisWorkbook.Worksheets("***1").Range("p" & m).Value = idate
            End If
        Next m
        Columns("P:P").ColumnWidth = 15.25
    End If
    ''''''''''''''清空原表下的資料''''''''''''''
    ThisWorkbook.Worksheets("***").Range("a4:p" & num).ClearContents
    ThisWorkbook.Save
End Sub