时间戳

首页 > 解决方案 > 将一列中存在的每个唯一值的所有行从数据集中复制到 vba 中的新工作表

excel - 将一列中存在的每个唯一值的所有行从数据集中复制到 vba 中的新工作表

问题描述

问题

  1. 我有一张表，首先我必须过滤最后一列。

  2. 对于最后一列中存在的每个唯一值，我必须将数据从第一列复制到最后一列

  3. 然后我必须添加新工作表并需要将此数据粘贴到新工作表中。

  4. 我对最后一列中存在的每个唯一值重复相同的过程 3。就像在最后一列是语言。所以首先对这一列进行排序。然后将每种语言的数据复制并粘贴到新工作表中。

标签： excelvba

解决方案

Sub LoopThroughAllItemsInFilters()

Range("G2", Range("G" & Cells(Rows.Count, 1).End(xlUp).Row)).Select
Selection.Copy

Columns("L").Select
ActiveSheet.Paste
ActiveSheet.Range("$L$1:$L$10000").RemoveDuplicates Columns:=1, Header:=xlYes

Dim ArrayDictionaryofItems As Object, Items As Variant, i As Long, Item As Variant

Set ArrayDictionaryofItems = CreateObject("Scripting.Dictionary")

With ActiveSheet

'show autofilter if not already shown on all rows

If Not .AutoFilterMode Then .UsedRange.AutoFilter
If .Cells.AutoFilter Then .Cells.AutoFilter

'Create list of unique items in column G that get filled into ArrayDictionaryofItems
Dim annoying As Double

If Range("G3").Value <> "" Then
annoying = 2
Items = Range(.Range("L2"), .Cells(Rows.Count, "L").End(xlUp))

'Fills ArrayDictionaryofItems to the UBOUND (max) count of unique items in column L.

For i = 1 To UBound(Items, 1)
ArrayDictionaryofItems(Items(i, 1)) = 1
Next

Else

Item = Range("G2").Value
annoying = 1
End If

'Filter multiple items if annoying is set to equal 2 because G3 is blank
If annoying = 2 Then

For i = 1 To UBound(Items, 1)
Sheets.Add After:=Sheets(i)
Next i

Sheets("DEFAULTERS").Select

Dim x As Double
x = 2

For Each Item In ArrayDictionaryofItems.keys
erow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
'autofilter on column b with this driver
.UsedRange.AutoFilter field:=7, Criteria1:=Item

Columns("A:G").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy

Sheets(x).Select
Columns("A:G").Select
ActiveSheet.Paste
Sheets("DEFAULTERS").Select

x = x + 1
Next Item
GoTo LINE99:
End If

'Filter a single item in column since G3 is blank and there is only one item in column G to filter
If annoying = 1 Then

Sheets.Add After:=ActiveSheet
Sheets("DEFAULTERS").Select

Item = Range("G2").Value
.UsedRange.AutoFilter field:=7, Criteria1:=Item
End If

Columns("A:G").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy

Sheets(2).Select
Columns("A:G").Select
ActiveSheet.Paste
Sheets("DEFAULTERS").Select

End With

LINE99:
With ActiveSheet
If .AutoFilterMode Then .UsedRange.AutoFilter
End With

End Sub

推荐阅读