For循環遍歷行並只添加唯一值

我有一個由2個循環組成的宏，但我只尋求第二個宏的幫助（以「Deal Name For Loop」命名爲註釋以供您參考）。第二個循環所做的是通過我的工作表，將單元格A1中的值收集在每個工作表中，然後將該值放入第4行中的下一個（到右側）空單元格中，在名稱與在工作表中的單元格I3中循環。生病包括我的代碼，因爲我理解它有點混亂。For循環遍歷行並只添加唯一值

我想這第二個循環要做的是不允許在第4行重複的值。基本上，宏將運行很多次，我不希望它編譯所有的值，從單元格A1，每次排入第4行。現在我一直試圖找到一種方法來刪除第4行中的重複值（如我的代碼的末尾所示），但我意識到這不是處理該問題的有效方式。我寧願For循環跳過複製單元格A1的過程，如果它到達其單元格A1已經在第4行的表單中的另一個表單中。

Sub AggLoop() 
    Dim ws As Worksheet 
    Dim rng As Range 
    Dim nme As String 
    Dim Crng As Range 
    Dim HdrCol As Range 
    Dim Site As String 
    Dim SearchRange As Range 
    Dim HdrRow As Range 
    Dim FinDate As Date 


Application.ScreenUpdating = False 

' Date For Loop 
    For Each ws In ActiveWorkbook.Worksheets 
    nme = ws.Range("I3").Text 
    Set rng = ws.Range("T7:T200") 

    'Dont Copy Data from these worksheets 
    If ws.Name <> "Portfolio" And ws.Name <> "Master" And ws.Name <> "Template" And ws.Name <> "Coal" And ws.Name <> "E&P" And ws.Name <> "Gas Gen" And ws.Name <> "Hydro" And ws.Name <> "LNG" And ws.Name <> "Midstream" And ws.Name <> "Solar" And ws.Name <> "Transmission" And ws.Name <> "Wind" Then 
    'Storing Copied data into cell (A5) 
     If IsEmpty(Sheets(nme).[A1]) Then 
     rng.Copy Sheets(nme).Range("A" & Rows.Count).End(xlUp) 

    'Storing next copied data below previously filled cell 
     Else 
      rng.Copy Sheets(nme).Range("A" & Rows.Count).End(xlUp).Offset(1, 0) 
     'Delete duplicates 
      Sheets(nme).Range("A4:A200").RemoveDuplicates Columns:=1, Header:=xlYes 
     'Sort by column A 
     Sheets(nme).Range("A4:XFD200").Sort key1:=Sheets(nme).Range("A5:A200"), order1:=xlAscending, Header:=xlYes 

    End If 
    End If 

Next ws 

' Deal Name For Loop 
For Each ws In ActiveWorkbook.Worksheets 
    nme = ws.Range("I3").Text 
    Set Crng = ws.Range("A1") 

    'Dont Copy Data from these worksheets 
    If ws.Name <> "Portfolio" And ws.Name <> "Master" And ws.Name <> "Template" And ws.Name <> "Coal" And ws.Name <> "E&P" And ws.Name <> "Gas Gen" And ws.Name <> "Hydro" And ws.Name <> "LNG" And ws.Name <> "Midstream" And ws.Name <> "Solar" And ws.Name <> "Transmission" And ws.Name <> "Wind" Then 
    'Storing Copied data into cell A4 
    If IsEmpty(Sheets(nme).[A4]) Then 
    Crng.Copy Sheets(nme).Range(4 & Columns.Count).End(xlLeft) 
    'Storing next copied data below previously filled cell 
     Else 
      Crng.Copy Sheets(nme).Cells(4, Columns.Count).End(xlToLeft).Offset(0, 1) 

    'Delete duplicates, this is the part that I am trying to change, so that the For Loop can ignore rather than delete 

      Sheets(nme).Range("D4:XFD4").RemoveDuplicates Columns:=Array(4, 500), Header:=xlNo 

    End If 
End If 

Next ws

來源

2017-08-30 EP17

你可以爲你去值添加到字典中並檢查它是否它已添加到您的工作表之前已存在。 – SJR

這一個選項是在你的第二個循環進行排序，並使用第三回路中加入如：

Sheets(nme).Range("A4:XFD200").Sort key1:=Sheets(nme).Range("D5:D200"), order1:=xlAscending, Header:=xlYes 

Dim i, j, k,l as integer 

j=0 
k=0 
l=0 

For i = 6 to 200 'based on your range 
    l=l 
    k=l 
    If Cells(i,4).Value=Cells(i-1,4) Then 
     'Nothing 
    Else 
     j=Cells(i,4).Value 
     l=j+k 
    End If 
Next i 

'Output l in the desired cell

來源

2017-08-30 16:22:28 Cyril

For循環遍歷行並只添加唯一值

回答

相關問題