在AutoFilter上运行macros并在新工作表中显示数据

其实我想要做的，我有以下数据与自动过滤，

– >我想为每个从过滤.ie中select的唯一名称创build新工作表，如果select了John和Alex，那么应该为John创build2个新工作表，并为Alex创build2个工作表，并且每个工作表显示自己的数据（Name + No + R）。 当下次如果主表得到更新，那么当我运行macros时应该附加新闻数据。 我使用下面的代码，但它不工作100％。

Sub mycar() x = 2 Do While Cells(x, 1) <> "" If Cells(x, 1) = "John" Then Worksheets("Sheet1").Rows(x).Copy Worksheets("Sheet2").Activate eRow = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row ActiveSheet.Paste Destination:=Worksheets("Sheet2").Rows(eRow) End If Worksheets("Sheet1").Activate x = x + 1 Loop End Sub 

– >这里只复制单引号中引用的数据。

– >第二次，如果我运行这个代码，它再次附加相同的数据与新的数据。

帮我避免这个错误。

谢谢。

Answer 1

正如所讨论的那样，在过程中还可以在Array中设置filter参数。 代码看起来像这样：

 Sub Solution() Dim shData As Worksheet Set shData = Sheets("Arkusz1") 'or other reference to data sheet Dim shNew As Worksheet shData.Activate 'get unique values based on Excel features Range("a1").AutoFilter Dim myArr As Variant myArr = Array("John", "max") Range("a1").AutoFilter Dim i As Long For i = 0 To UBound(myArr) shData.Range("$A$1").AutoFilter Field:=1, Criteria1:=myArr(i), _ Operator:=xlAnd On Error Resume Next Sheets(myArr(i)).Range("A1").CurrentRegion.ClearContents If Err.Number = 0 Then Range("A1").CurrentRegion.Copy Sheets(myArr(i)).Range("A1") Else Set shNew = Sheets.Add(After:=Sheets(Sheets.Count)) shData.Range("A1").CurrentRegion.Copy shNew.Range("A1") shNew.Name = myArr(i) Err.Clear End If Next i 'removing filter in master sheet shData.Range("a1").AutoFilter End Sub 

Answer 2

replaceWorksheets("Sheet1").Rows(x).Copy Worksheets("Sheet1").Rows(x).EntireRow.Copy

在添加信息之前清除目标工作表。

Answer 3

我经常做相当类似的练习。 因此，我在代码中提供了一些可能的解决scheme。 它适用于列A中的所有唯一值，并创build（如果不存在）具有与filter参数相同的名称的工作表。

 Sub Solution() Dim shData As Worksheet Set shData = Sheets("Arkusz1") 'or other reference to data sheet Dim shNew As Worksheet 'get unique values based on Excel features 'i guess some will not like it but I do :) Range("a1").AutoFilter Range("A1").CurrentRegion.Columns(1).Copy Range("ww1") Range("ww1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes 'be sure that range where you copy (like ww1) is empty range around Dim myArr As Variant myArr = Range(Range("ww2"), Range("ww2").End(xlDown)) Range("ww1").CurrentRegion.ClearContents 'some cleaning Range("a1").AutoFilter ' Dim i As Long For i = 1 To UBound(myArr, 1) ActiveSheet.Range("$A$1").AutoFilter Field:=1, Criteria1:=myArr(i, 1), _ Operator:=xlAnd On Error Resume Next 'this is for two reason- to check if appropriate sheet exists, if so to clean top area 'if you need to append you would comment this line Sheets(myArr(i, 1)).Range("A1").CurrentRegion.ClearContents If Err.Number = 0 Then 'if you need to append only you would need to set range-to-copy a bit different Range("A1").CurrentRegion.Copy Sheets(myArr(i, 1)).Range("A1") Else Set shNew = Sheets.Add(After:=Sheets(Sheets.Count)) shData.Range("A1").CurrentRegion.Copy shNew.Range("A1") shNew.Name = myArr(i, 1) Err.Clear End If Next i End Sub 

这不能完全满足您的要求，但可能是一个完善的解决scheme，相应地改进。

Answer 4

标题##下面的代码是根据您的要求。 根据您的要求修改它。

---

 Private Sub Worksheet_Calculate() Dim x As Integer Dim rnge As Integer x = Range(Selection, Selection.End(xlDown)).Count rnge = ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Rows.Count If Range("E1").Value > rnge Then Range("A1").Select Range(Selection, Selection.End(xlToRight)).Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy Sheets(2).Select ActiveSheet.Paste End If End Sub