Question

假设我们有这些专栏

Sarah    Smith     1234566 UK
Homer    Simpson   3456677 USA
Max      Power     4567932 Canada
Meg      Griffin   5689321 USA
Sarah    Smith   345677   USA

所以我想在工作表中提取一个人的所有数据，所以Sarah Smith有自己的工作表显示她的信息，本垒打simpson有他自己的显示他的信息.. 我编写了这段代码，但是当我运行它时，它开始了每项工作，但它在每个工作表的顶部添加了一行！所以对于莎拉史密斯工作表，它从第2行开始，因为荷马辛普森从第3行开始。最大功率从第4行开始？知道为什么??我希望每张纸从第1行开始

Private Sub CommandButton1_Click()
    Dim WorksheetsExists As Boolean, e
    Application.ScreenUpdating = False
    With Range("A1").CurrentRegion
        With .Offset(1).Columns(1)
            For Each e In Filter(.Parent.Evaluate("transpose(if(countif(offset(" & _
                                                  .Address & ",0,0,row(1:" &     .Rows.Count & "))," & .Address & ")=1," & _
                                                  .Address & ",char(2)))"), Chr(2), False)
                .Offset(-1).AutoFilter 1, e
                Range("A1").CurrentRegion.Offset(0, 0).Resize(.Rows.Count, 25).SpecialCells(12).Copy
                On Error Resume Next
                WorksheetExists = (Sheets(e).Name <> "")
                If WorksheetExists = False Then
                    Sheets.Add(After:=Sheets(Sheets.Count)).Name = e
                    Sheets(e).Range("A" & Sheets(e).Range("A" & Rows.Count).End(xlUp).Row).Offset(1).PasteSpecial
                    On Error GoTo 0
                Else
                    Sheets(e).Range("A" & Sheets(e).Range("A" & Rows.Count).End(xlUp).Row).Offset(1).PasteSpecial
                End If
                Sheets(e).Columns.AutoFit
            Next
        End With
        .AutoFilter
    End With
    Application.ScreenUpdating = False
End Sub

Answer 1

我对此进行了测试，只做了一些小改动：

Sub sof20317616ExtractingDataFrom1Worksheet2Another()
  Dim lRow As Long
  Dim WorksheetExists As Boolean, e

  Application.ScreenUpdating = False
  With Range("A1").CurrentRegion
    'MsgBox .Offset(1).Columns(1).Rows.Count
    With .Offset(1).Columns(1)
      For Each e In Filter(.Parent.Evaluate("transpose(if(countif(offset(" & _
        .Address & ",0,0,row(1:" & .Rows.Count & "))," & .Address & ")=1," & _
        .Address & ",char(2)))"), Chr(2), False)
        .Offset(-1).AutoFilter 1, e
        'MsgBox .Rows.Count
        'Range("A1").CurrentRegion.Offset(0, 0).Resize(.Rows.Count, 25).SpecialCells(xlCellTypeVisible).Copy
        .Offset(0, 0).Resize(.Rows.Count, 25).SpecialCells(xlCellTypeVisible).Copy
        On Error Resume Next
        WorksheetExists = (Sheets(e).Name <> "")
        If WorksheetExists = False Then
          Sheets.Add(After:=Sheets(Sheets.Count)).Name = e
          On Error GoTo 0
        End If
        lRow = Sheets(e).Range("A" & Rows.Count).End(xlUp).Row
        Sheets(e).Range("A" & lRow).Offset(0).PasteSpecial
        Sheets(e).Columns.AutoFit
      Next
    End With
    .AutoFilter
  End With

  Application.ScreenUpdating = True
End Sub

初始数据表如下：

enter image description here

Answer 2

这不是你问题本身的答案，但我认为你的WorkSheetExists布尔测试存在缺陷。请注意，一旦设置为True，即第一次存在名称为e值的工作表，它就不会再次变为False。这是因为On Error Resume下一个语句在该名称的工作表不存在时会跳过该错误。它不会将WorkSheetExists变量设置为False。您需要在代码中明确地执行此操作，如：

On Error Resume Next
WorksheetExists = False
WorksheetExists = (Sheets(e).Name <> "")
If WorksheetExists = False Then ...

更好的是，创建一个单独的WorkSheetExists函数，只需将名称传递给：

Function WorkSheetExists (WorkbookToTest as Workbook, WorksheetName as String) as Boolean
    On Error Resume Next
    WorksheetExists = WorkbookToTest.Sheets(WorksheetName).Name <> ""
End Function

在excel中将数据从一个工作表提取到另一个工作表

2 个答案: