Excel 停下来，包括第二排

因此，我设法找到了这段代码，它似乎能够很好地抓取数据，根据在H列中找到的内容，将数据拆分为单独的新选项卡。然而，在它创建的所有新选项卡上，它仍然保留了原始的第2行-我确信在其中的某个地方，我只需要更改一个值，但还没有发现在哪里

Option Explicit

'<<<<  Create a new sheet for every Unique value  >>>>>

'This example copy all rows with the same value in the first column of
'the range to a new worksheet. It will do this for every unique value.
'The sheets will be named after the Unique value.

'Note: this example use the function LastRow in the ModReset module

Sub Copy_To_Worksheets()
'Note: This macro use the function LastRow
Dim My_Range As Range
Dim FieldNum As Long
Dim CalcMode As Long
Dim ViewMode As Long
Dim ws2 As Worksheet
Dim Lrow As Long
Dim cell As Range
Dim CCount As Long
Dim WSNew As Worksheet
Dim ErrNum As Long

'Set filter range on ActiveSheet: A11 is the top left cell of your filter range
'and the header of the first column, D is the last column in the filter range.
'You can also add the sheet name to the code like this :
'Worksheets("Sheet1").Range("A11:D" & LastRow(Worksheets("Sheet1")))
'No need that the sheet is active then when you run the macro when you use this.
Set My_Range = Range("A2:S65000")
My_Range.Parent.Select

If ActiveWorkbook.ProtectStructure = True Or _
   My_Range.Parent.ProtectContents = True Then
    MsgBox "Sorry, not working when the workbook or worksheet is protected", _
           vbOKOnly, "Copy to new worksheet"
    Exit Sub
End If

'This example filters on the first column in the range(change the field if needed)
'In this case the range starts in A so Field:=1 is column A, 2 = column B, ......
FieldNum = 8

'Turn off AutoFilter
My_Range.Parent.AutoFilterMode = False

'Change ScreenUpdating, Calculation, EnableEvents, ....
With Application
    CalcMode = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
End With
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False

'Add a worksheet to copy the a unique list and add the CriteriaRange
Set ws2 = Worksheets.Add

With ws2
    'first we copy the Unique data from the filter field to ws2
    My_Range.Columns(FieldNum).AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=.Range("H1"), Unique:=True

    'loop through the unique list in ws2 and filter/copy to a new sheet
    Lrow = .Cells(Rows.Count, "H").End(xlUp).Row
    For Each cell In .Range("H2:H" & Lrow)

        'Filter the range
        My_Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
                                                        Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")

        'Check if there are no more then 8192 areas(limit of areas)
        CCount = 0
        On Error Resume Next
        CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible) _
                 .Areas(1).Cells.Count
        On Error GoTo 0
        If CCount = 0 Then
            MsgBox "There are more than 8192 areas for the value : " & cell.Value _
                 & vbNewLine & "It is not possible to copy the visible data." _
                 & vbNewLine & "Tip: Sort your data before you use this macro.", _
                   vbOKOnly, "Split in worksheets"
        Else
            'Add a new worksheet
            Set WSNew = Worksheets.Add(After:=Sheets(Sheets.Count))
            On Error Resume Next
            WSNew.Name = cell.Value
            If Err.Number > 0 Then
                ErrNum = ErrNum + 1
                WSNew.Name = "Error_" & Format(ErrNum, "0000")
                Err.Clear
            End If
            On Error GoTo 0

            'Copy the visible data to the new worksheet
            My_Range.SpecialCells(xlCellTypeVisible).Copy
            With WSNew.Range("A1")
                ' Paste:=8 will copy the columnwidth in Excel 2000 and higher
                ' Remove this line if you use Excel 97
                .PasteSpecial Paste:=8
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
                .Select
            End With
        End If

        'Show all data in the range
        My_Range.AutoFilter Field:=FieldNum

    Next cell

    'Delete the ws2 sheet
    On Error Resume Next
    Application.DisplayAlerts = False
    .Delete
    Application.DisplayAlerts = True
    On Error GoTo 0

End With

'Turn off AutoFilter
My_Range.Parent.AutoFilterMode = False

If ErrNum > 0 Then
    MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" _
         & vbNewLine & "There are characters in the name that are not allowed" _
         & vbNewLine & "in a sheet name or the worksheet already exist."
End If

'Restore ScreenUpdating, Calculation, EnableEvents, ....
My_Range.Parent.Select
ActiveWindow.View = ViewMode
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = CalcMode
End With

End Sub

选项显式
'>>
'此示例复制的第一列中具有相同值的所有行
'将范围更改为新工作表。它将为每一个独特的价值做到这一点。
'图纸将以唯一值命名。
'注意：此示例使用ModReset模块中的函数LastRow
子副本到工作表（）
'注意：此宏使用函数LastRow
将我的_范围变暗为范围
Dim FieldNum尽可能长
暗淡的CalcMode与长
将视图模式变暗为长
将ws2设置为工作表
暗淡的光线和长的一样
暗淡单元格作为范围
长帐
新建为工作表
Dim ErrNum尽可能长
'在ActiveSheet上设置筛选范围：A11是筛选范围的左上角单元格
'并且第一列的标题D是筛选范围中的最后一列。
'您还可以将图纸名称添加到代码中，如下所示：
'工作表（“表1”）.范围（“A11:D”和LastRow（工作表（“表1”）））
'使用此选项时，在运行宏时，无需工作表处于活动状态。
设置我的范围=范围（“A2:S65000”）
My_Range.Parent.Select
如果ActiveWorkbook.ProtectStructure=True或_
My_Range.Parent.ProtectContents=则为True
MsgBox“抱歉，工作簿或工作表受保护时不工作”_
vbOKOnly，“复制到新工作表”
出口接头
如果结束
'此示例筛选范围中的第一列（如果需要，请更改字段）
'在这种情况下，范围从so字段开始：=1为A列，2为B列。。。。。。
FieldNum=8
'关闭自动过滤器
My_Range.Parent.AutoFilterMode=False
'更改屏幕更新、计算、启用事件。。。。
应用
CalcMode=.Calculation
.Calculation=xlCalculationManual
.ScreenUpdate=False
.EnableEvents=False
以
ViewMode=ActiveWindow.View
ActiveWindow.View=xlNormalView
ActiveSheet.DisplayPageBreaks=False
'添加工作表以复制唯一列表并添加标准范围
设置ws2=工作表。添加
与ws2
'首先，我们将唯一数据从筛选器字段复制到ws2
My_Range.Columns（FieldNum）.AdvancedFilter_
操作：=xlFilterCopy_
CopyToRange:=.Range（“H1”），唯一：=真
'循环浏览ws2中的唯一列表并筛选/复制到新工作表
Lrow=.Cells（Rows.Count，“H”）.End（xlUp）.Row
对于范围内的每个单元格（“H2:H”和Lrow）
'过滤范围
My_Range.AutoFilter字段：=FieldNum，准则1:=“=”&_
替换（替换（替换（cell.Value、“~”、“~~”、“*”、“~*”、“？”、“~？”）
'检查是否没有超过8192个区域（区域限制）
帐户=0
出错时继续下一步
CCount=My_Range.Columns（1）.SpecialCells（xlCellTypeVisible）_
.面积（1）.单元格.计数
错误转到0
如果CCount=0，则
MsgBox“值有8192个以上的区域：”&cell.value_
&vbNewLine&“无法复制可见数据。”_
&vbNewLine&“提示：在使用此宏之前对数据进行排序。”_
VBookOnly，“在工作表中拆分”
其他的
'添加新工作表
设置WSNew=Worksheets.Add（之后：=Sheets（Sheets.Count））
出错时继续下一步
WSNew.Name=cell.Value
如果错误编号>0，则
ErrNum=ErrNum+1
WSNew.Name=“Error”&格式（ErrNum，“0000”）
呃，明白了
如果结束
错误转到0
'将可见数据复制到新工作表
My_Range.SpecialCells（xlCellTypeVisible）。复制
使用WSNew.Range（“A1”）
'粘贴：=8将在Excel 2000及更高版本中复制列宽
'如果使用Excel 97，请删除此行
.Paste特殊粘贴：=8
.Paste特殊XLPaste值
.Paste特殊XLPaste格式
Application.CutCopyMode=False
.选择
以
如果结束
'显示范围内的所有数据
My_Range.AutoFilter字段：=FieldNum
下一个细胞
'删除ws2工作表
出错时继续下一步
Application.DisplayAlerts=False
.删除
Application.DisplayAlerts=True
错误转到0
以
'关闭自动过滤器
My_Range.Parent.AutoFilterMode=False
如果ErrNum>0，则
MsgBox“手动重命名每个以“错误”开头的工作表名称”_
&vbNewLine&“名称中有不允许的字符”_
&vbNewLine&“在工作表名称或工作表中已存在。”
如果结束
'还原屏幕更新、计算、启用事件。。。。
My_Range.Parent.Select
ActiveWindow.View=ViewMode
应用
.ScreenUpdate=True
.EnableEvents=True
.Calculation=CalcMode
以
端接头

---

希望这只是我需要的一个小改动。

我相信你是在复制自动筛选显示的单元格，所以标题会显示出来。你可以看看这样做

Set rVisible=r.SpecialCells（xlCellTypeVisible）Set rmodify=rVisible.Areas（1）.Resize（rVisible.Areas（1）.Rows.Count-1，2）.Offset（1，0）

然后复制

rVisible

，因此这里我有一个新的范围

rModify

来保存结果，但是你可以直接在

区域中执行，它使用
调整大小
和
偏移
。。。。。。可能有一种简单的方法，那么，你想只复制过滤区域，但不复制标题吗？更改
My_范围。特殊单元格（xlCellTypeVisible）。将
复制到
My_范围。偏移量（1）。（xlCellTypeVisible）。复制
@GMalc：恐怕这在不连续的范围内不起作用（如
（xlCellTypeVisible）
）。这是必要的