关于excel的VBA修改,添加表头

发布网友发布时间：2022-09-11 03:02

共1个回答

热心网友时间：2024-10-20 09:15

两个方法，一个是改造 zSELSHE 这个子过程：

Sub zSELSHE(zNAME As String)
    On Error GoTo zADD
    Sheets(zNAME).Select
    Exit Sub
zADD:
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = zNAME
    Sheets(zNAME).Select
    Rows(1).Copy Destination:=Sheets(zNAME).Rows(1)    ' 将标题行粘贴到新工作表中
End Sub

另一个方法，在“拆分工作表”过程中，修改这一句：

If [A1] = "" Then Range("A1").Select

改为：

If [A1] = "" Then Sheet(zNAME).Rows(1).Copy Destination:=Range("A1")

另外，原来代码中对工作表的引用有点混乱，建议修改如下（那个子过程不需要了）：

Sub 拆分工作表()

Dim zROW As Integer, zHS As Integer
Dim I As Integer, J As Integer
Dim zNAME As String
Dim mYcell As Range
Dim sht_Original As Worksheet, sht_New As Worksheet

    Application.ScreenUpdating = False
    'zNAME = ActiveSheet.Name
    Set sht_Original = ActiveSheet    '定义原始数据表

    For Each sht_New In Worksheets
        If sht_New.Name <> sht_Original.Name Then sht_Original.Cells.Clear  '清除以前拆分的记录
    Next sht_New
    Application.DisplayAlerts = True

    zROW = sht_Original.Range("A1").End(xlDown).Row

    For I = 1 To zROW
        '查找是否已有拆分工作表
        For Each sht_New In Worksheets
            If sht_New.Name = sht_Original.Cells(I, 1) Then Exit For  '如果已有拆分工作表存在，则跳出循环
        Next

        If sht_New Is Nothing Then  '当循环完成，而sht_new仍是空值，说明没有找到拆分工作表
            Set sht_New = Worksheets.Add    '添加新拆分工作表
        End If

        '如果拆分工作表的第一行为空，则复制标题行
        If sht_New.Range("A1") = "" Then sht_Original.Rows(1).Copy destinatiol:=sht_New.Rows(1)
        '将数据复制到拆分工作表中
        sht_Original.Rows(I).Copy Destination:=sht_New.Range("A65535").End(xlUp).Offset(1)
    Next
    MsgBox "拆分工作完成。", vbInformation, "报告"
End Sub