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

可以说我们有这些专栏

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

所以我想把一个人的所有数据提取出来放在工作表中，所以莎拉·史密斯有自己的工作表，显示她的信息，荷马辛普森有他自己的信息显示他的信息.. 我写了这个代码，但是当我运行它开始每个工作但它在每个工作表顶部添加一行！ 所以对于莎拉史密斯工作表，它从第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

我testing了一下，做了一些小的修改：

 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 

最初的数据表是这样的：

Answer 2

这不是对您的问题本身的答案，但我认为在WorkSheetExists的布尔testing中存在一个缺陷。 请注意，一旦将其设置为True，即第一次存在名称为e的工作表时，它将不会再变为False。 这是因为On Error Resume next语句在该名称的工作表不存在时将跳过该错误。 它不会将您的WorkSheetExistsvariables设置为False。 你需要在代码中明确地这样做：

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

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

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