vba 在自动筛选上运行宏并在新工作表中显示数据

run macro on AutoFilter and show data in new sheet

提问by Ronak Mehta

Actually what i want to do , i have following data With Auto Filtering ,

实际上我想做的是，我有以下自动过滤数据，

-> I want to create new sheet for each unique Name selected from filtering .i.e. if John and Alex are selected then 2 new sheets should be created one for John and second for Alex , and each of them show own data (Name + No + R). When Next time if master sheet get updated then news data should be appended when i run macro. i'm using following code but its not working 100%.

-> 我想为从过滤中选择的每个唯一名称创建新工作表。即，如果选择了 John 和 Alex，则应为 John 创建 2 个新工作表，为 Alex 创建第二个工作表，并且每个工作表都显示自己的数据（姓名 + 否 + R）。下次如果主表更新时，则应在我运行宏时附加新闻数据。我正在使用以下代码，但它不能 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

-> Here it copy only single data Written in the quotes.

-> 这里它只复制写在引号中的单个数据。

-> Second time if i run this code , it is appending same data again with new data.

-> 如果我第二次运行此代码，它会再次使用新数据附加相同的数据。

Help me to avoid this mistakes.

帮助我避免这个错误。

Thank you.

谢谢你。

回答by Kazimierz Jawor

As discussed there is other possibility to set filter parameters in Array in procedure. The code would look like this one:

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

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").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

回答by Daniel M?ller

Substitute Worksheets("Sheet1").Rows(x).Copyby Worksheets("Sheet1").Rows(x).EntireRow.Copy

替代Worksheets("Sheet1").Rows(x).Copy的Worksheets("Sheet1").Rows(x).EntireRow.Copy

And clear the destination worksheet before adding information.

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

回答by Kazimierz Jawor

I do quite similar exercise quite often. Therefore I provide full possible solution with some comments inside the code. It works for all unique values in column A and creates (if not exists) sheet with appropriate name equals to filter parameters.

我经常做类似的运动。因此，我提供了完整的可能解决方案，并在代码中添加了一些注释。它适用于 A 列中的所有唯一值，并创建（如果不存在）具有适当名称等于过滤器参数的工作表。

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").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

This could not fully meet your requirements but could be a complete solution to improve accordingly.

这不能完全满足您的要求，但可以作为相应改进的完整解决方案。

回答by Vishwas - xCELL Solutions

Heading ##Below code is as per your requirement. Modify it based upon your requirement.

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

---

---

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