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循环遍历行并只添加唯一值

回答

相关问题