Question

我有一个很大的excel文件，包含股票市场上不同人的所有交易。该文件有多张代表不同月份的表格。然而，为了计算他们的回报（还有其他原因），我需要将他们的投资组合ID安排在彼此之下（一个Portolio ID号代表一个人）。由于这些投资组合ID位于每张表格中，我需要以某种方式使用宏来复制所有这些投资组合ID，这些投资组合ID来自彼此之下的所有不同表格（月份）。

这就是我现在所拥有的：

Sub apply_autofilter_across_worksheets()
 Dim p As Integer, q As Integer
 p = Worksheets.Count
 For q = 1 To p
 With Worksheets(q)
 .Range("A1").AutoFilter field:=1, Criteria1:="6*"
 End With
 Next q
 End Sub

投资组合ID（人）的范围从`695678到7128631。

Criteria1:="6*"我以为我可以使用两个宏，所有内容都以数字6*开头，所有内容都以数字7*开头。

Sub Macro13()
'
' Macro13 Macro
'   

'
Columns("B:B").Select
Selection.AutoFilter
ActiveSheet.Range("$B$1:$B$271806").AutoFilter Field:=1, Criteria1:= _   
    "697139"
Sheets("13 feb - 5 Mar ").Select
Columns("B:B").Select
Selection.AutoFilter
ActiveSheet.Range("$B$1:$B$259216").AutoFilter Field:=1, Criteria1:= _
    "697139"
Sheets("5 - 15 Mar ").Select
Columns("B:B").Select
Selection.AutoFilter
ActiveSheet.Range("$B$1:$B$210584").AutoFilter Field:=1, Criteria1:= _
    "697139"
Sheets("15 Mar - 12 Apr").Select
Columns("B:B").Select
Selection.AutoFilter
ActiveSheet.Range("$B$1:$B$240768").AutoFilter Field:=1, Criteria1:= _
    "697139"
Sheets("Blad5").Select
Columns("B:B").Select
Selection.AutoFilter
ActiveSheet.Range("$B$1:$B$317496").AutoFilter Field:=1, Criteria1:= _
    "697139"
Sheets("4-13 feb").Select
Range("A181:N184").Select
End Sub

此宏适用于一个投资组合ID。但是我仍然需要将它从每个工作表复制到一个新工作表并为每个工作组ID运行它。（我有超过数千个投资组合ID）

请帮助：）

Answer 1

使用以下控件尝试并测试以下代码：

在我的最终创建了100万个ID，生成了690k和730k之间的值，以便与您的数据紧密匹配。
我有5张，每张200k ID。我创建了一个名为Consolidated的工作表作为我的结果的输出表。

以下代码在我的机器上运行大约3秒钟，消除所有重复项并生成从100万行ID中收集的17,186 ID的完全唯一列表。列表最后排序。

Sub GetAllPortfolioIDs()

    Dim WS As Worksheet, ConsWS As Worksheet
    Dim Dict As Object
    Dim RngVal As Variant, ElemVal As Variant
    Dim LRow As Long

    Start = Timer()

    Set ConsWS = ThisWorkbook.Sheets("Consolidated")
    Set Dict = CreateObject("Scripting.Dictionary")

    For Each WS In ThisWorkbook.Worksheets
        If WS.Name <> ConsWS.Name Then
            With WS
                LRow = .Range("B" & .Rows.Count).End(xlUp).Row
                RngVal = .Range("B2:B" & LRow).Value
            End With
            With Dict
                For Each ElemVal In RngVal
                    If Not .Exists(ElemVal) And Len(ElemVal) > 0 Then
                        .Add ElemVal, Empty
                    End If
                Next ElemVal
            End With
        End If
    Next WS

    With ConsWS
        .Range("A2").Resize(Dict.Count).Value = Application.Transpose(Dict.Keys)
        .Range("A2").SortSpecial Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlGuess
    End With

    Debug.Print Timer() - Start

End Sub

enter image description here

如果有帮助，请告诉我们。

将项目组合ID复制到有序列表

1 个答案: