將投資組合ID複製到有序列表

Question

我有一個很大的excel文件，包含來自股市不同人的所有交易。該文件有多張表示不同月份的工作表。然而，爲了計算他們的回報（還有其他原因），我需要將他們的投資組合ID排列在彼此之下（一個Portolio 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 

該宏適用於一個Portfolio ID。但是，我仍然必須將其從每張表格複製到一張新表格，併爲每個組合ID運行它。 （我有超過十萬的投資組合的ID）

請幫助:)

Answer 1

下面的代碼是經得起使用以下控件來進行測試：

1. 創建在我結束百萬的ID，之間產生的價值690k和730k，以緊密匹配您的數據。
2. 我有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 

讓我們知道這會有所幫助。