Question

我有一个包含2列的工作表（主要），如下所示：

姓名国籍

约翰史密斯英国人

Chris Banks American

Jean Pierre French

我的要求是根据国籍数据将Worksheet（main）中的单元格数据传输到辅助工作表。英国的辅助工作表应如下所示：

姓名国籍

约翰史密斯英国人

只有与英国国籍相关的数据才能按照上述过滤到此工作表。我已经看过使用粘贴链接，但这并不完全符合我的要求。非常感谢任何帮助/建议。提前谢谢！

Answer 1

首先创建一个工作簿，然后在“Sheet1”中输入您需要的数据：

Sheet1 http://im59.gulfup.com/fULkNN.png

然后添加如上所示的命令按钮（ActiveX）并添加代码。

所以我为你写的代码将是：

删除除“Sheet1”以外的所有先前工作表。
添加“临时”表格。
将“国籍”栏（B栏）从Sheet1复制到TempSheet。
删除所有重复项以获取表格中的唯一国籍列表。
为每个独特的国籍创建一张以国籍命名的表格。
在“Sheet1”中按照与此国籍相匹配的名称进行过滤，并将结果复制到以相应国籍命名的创建工作表。
直到最后为所有独特的国籍做这件事。
自动调整新创建的工作表中的所有列宽。
最后删除“Temp”表。

代码：

Private Sub CommandButton1_Click()

Application.DisplayAlerts = False

For Each Worksheet In ActiveWorkbook.Worksheets
Worksheet.Visible = True
Next

For Each Worksheet In ActiveWorkbook.Worksheets
If Worksheet.Name <> "Sheet1" Then Worksheet.Delete
Next

Worksheets.Add().Name = "TempSheet"

lastrow = Worksheets("Sheet1").Cells(Worksheets("Sheet1").Rows.Count, "A").End(xlUp).Row

Dim copyRange  As Range
Set copyRange = Worksheets("Sheet1").Range("B2:B" & lastrow)

copyRange.Copy Destination:=Worksheets("TempSheet").Range("A1")

On Error Resume Next
Lastrow2 = Worksheets("TempSheet").Cells(Worksheets("TempSheet").Rows.Count, "A").End(xlUp).Row
Worksheets("TempSheet").Range("$A$1:$A$" & Lastrow2).RemoveDuplicates Columns:=1, Header:=xlNo

Lastrow3 = Worksheets("TempSheet").Cells(Worksheets("TempSheet").Rows.Count, "A").End(xlUp).Row

For i = 1 To Lastrow3
Worksheets.Add(After:=Sheets(Sheets.Count)).Name = Worksheets("TempSheet").Range("A" & i).Value

With Worksheets("Sheet1")
    .AutoFilterMode = False

    With .Range("A1:B" & lastrow)
    .AutoFilter
    .AutoFilter Field:=2, Criteria1:=Worksheets("TempSheet").Range("A" & i).Value, Operator:=xlFilterValues
    Set copyFrom = .SpecialCells(xlCellTypeVisible).EntireRow
    End With
End With

With Worksheets(Worksheets("TempSheet").Range("A" & i).Value)
    copyFrom.Copy .Rows(1)
End With

Worksheets(Worksheets("TempSheet").Range("A" & i).Value).Columns("A:Z").AutoFit

With Worksheets("Sheet1")
    .AutoFilterMode = False
End With
Next i

Worksheets("TempSheet").Delete

Sheets("Sheet1").Activate

Application.DisplayAlerts = True

End Sub

我相信这可以满足你的需要。

示例文件：https://www.mediafire.com/?0zfooccuh86ikq8

根据条件在工作表之间复制单元格数据

1 个答案: