在Excel中清除内容的VBA代码

如果B列中的值为空白（即，客户与前一个非空行相同），并且它们需要清除，那么我只需要帮助清除单元格的内容（L，M）在每个客户的L列中都是重复的。在Excel中清除内容的VBA代码

例如：

 Customer (B)    Sales (L) Description (M) 
row1 James      Laptop  Laptop sold 
row2        Laptop  Laptop sold 
row3       Iphone  Iphone sold 
row4 Brian     Iphone  Iphone sold 
row5        Mouse  Mouse sold 
row6        Iphone  Iphone sold

期望的结果：

 Customer (B)    Sales (L) Description (M) 
row1 James      Laptop  Laptop sold 
row2        
row3       Iphone  Iphone sold  
row4 Brian     Iphone  Iphone sold 
row5        Mouse  Mouse sold 
row6

来源

2017-03-31 Kix Malovic

你尝试过什么？这是一个非常简单的VBA循环。您想保留行，还是在列B空白时将其删除？ – BruceWayne

重复将始终是名称行中的一个，还是会有两个相同的事物没有名称，因此Brian会有两个鼠标，或只有Iphone，因为这是Brian在同一行中的那个？ –

请查看@Tom的答案。它给你你想要的东西。 “如果有用，请点击答案旁边的复选标记，不要忘记给服务员打电话。” – Masoud

看起来像什么你想要的是清除range(E:F)其中B是空白的，range(E:F)是与上面相同的行？如果是这种情况，您将需要这样的事情：

Sub Testing2() 
    Dim x 
    For Each c In Range(Range("E1"), Range("E" & Rows.count).End(xlUp)) 
     If Range("B" & c.row).Value <> "" Then 
      x = 1 
      Do Until Range("B" & c.row + x).Value <> "" And c.row + x < Range("E" & Rows.count).End(xlUp).row 
       Range("E" & c.row).Select 
       If Range("E" & c.row).Value = Range("E" & c.row + x).Value And Range("F" & c.row).Value = Range("F" & c.row + x).Value Then 
        Range("E" & c.row + x & ":F" & c.row + x).ClearContents 
       End If 
       If c.row + x >= Range("E" & Rows.count).End(xlUp).row Then 
        Exit Do 
       End If 
       x = x + 1 
      Loop 
     End If 
     If Range("B" & c.row).Value = "" Then 
      x = 1 
      Do Until Range("B" & c.row + x).Value <> "" And c.row + x < Range("E" & Rows.count).End(xlUp).row 
       Range("E" & c.row).Select 
       If Range("E" & c.row).Value = Range("E" & c.row + x).Value And Range("F" & c.row).Value = Range("F" & c.row + x).Value Then 
        Range("E" & c.row + x & ":F" & c.row + x).ClearContents 
       End If 
       If c.row + x >= Range("E" & Rows.count).End(xlUp).row Then 
        Exit Do 
       End If 
       x = x + 1 
      Loop 
     End If 
    Next 
End Sub

这将从顶部开始，并努力寻找每个人的重复。

或者你可以像这样的东西删除该行：@Masoud后

Sub Testing2() 
    Dim x 
    For Each c In Range(Range("E1"), Range("E" & Rows.count).End(xlUp)) 
     If Range("B" & c.row).Value <> "" Then 
      x = 1 
      Do Until Range("B" & c.row + x).Value <> "" 
       If Range("E" & c.row).Value = Range("E" & c.row + x).Value And Range("F" & c.row).Value = Range("F" & c.row + x).Value Then 
        Range("A" & c.row + x).Select 
        ActiveCell.Offset(0, 0).Rows("1:1").EntireRow.Select 
        Selection.Delete shift:=xlUp 
       End If 
       x = x + 1 
      Loop 
     End If 
    Next 
End Sub

来源

2017-03-31 14:53:20 Mike

这不会删除第6行，因为副本是两行而不是一行。 –

请注意@ScottCraner评论。您的代码不能充分解决问题。 – Masoud

这不是我所说的，查看第6行被清除之前和之后的数据，并不是因为它等于上面的行，而是代码上面的第2行仅查找上面的行。 –

更新评论 此相匹配的输出所需

Option Explicit 
Sub RemoveDuplicates() 
    Dim rng As Range, c As Range, rCell As Range 
    Dim temp As Range 

    ' Update this to reference your sheet 
    With Sheet1 
     Set rng = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)) 
    End With 

    For Each rCell In rng 
     Set c = Nothing 
     If rCell.Offset(0, 1) = vbNullString Then 
      With rCell.Offset(0, 1) 
       Set temp = Range(.End(xlUp), .End(xlDown).Offset(-1, 0)).Offset(0, 3) 
      End With 
      Set c = temp.Find(rCell.Offset(0, 4), lookat:=xlWhole, after:=rCell.Offset(0, 4)) 

      If Not c Is Nothing Then 
       If rCell.Offset(0, 5) = c.Offset(0, 1) And c.Row <> rCell.Row Then 
        Range(rCell.Offset(0, 4), rCell.Offset(0, 5)).ClearContents 
       End If 
      End If 
     End If 
    Next rCell 
End Sub

看一看下面。循环遍历工作表中的所有行，并且如果B列中的单元格为空，则尝试查找它是否存在于工作表中的其他位置。如果是，则清除该行的内容。

我认为你需要定义更多你认为重复的东西。至于你的问题你：

假ROW3（ROW6复印件）
删除2行（不重复，除非你忽视客户）

所以，你必须在你的逻辑休息。如果您比较客户（即离开Row3），那么只有row6应该被删除。但是，如果您没有比较客户以及重复项的部分内容，那么row3也应该从期望的结果中删除。

Option Explicit 
Public Sub RemoveDuplicates() 
    Dim rng As Range, c As Range, rCell As Range 

    ' Update this to reference your sheet 
    With Sheet1 
     Set rng = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)) 
    End With 

    For Each rCell In rng 
     Set c = Nothing 
     If rCell.Offset(0, 1) = vbNullString Then 
      Set c = rng.Offset(0, 4).Find(rCell.Offset(0, 4), lookat:=xlWhole, after:=rCell.Offset(0, 4)) 

      If Not c Is Nothing Then 
       '' If not including customer in comparison 
       If rCell.Offset(0, 5) = c.Offset(0, 1) And c.Row <> rCell.Row Then 
       '' Uncomment below and comment above if comparing customers as well 
       'If rCell.Offset(0, 5) = c.Offset(0, 1) And rCell.Offset(0, 1).Value = c.Offset(0, -3).Value And c.Row <> rCell.Row Then 

        Range(rCell.Offset(0, 4), rCell.Offset(0, 5)).ClearContents 
       End If 
      End If 
     End If 
    Next rCell 
End Sub

来源

2017-03-31 16:02:50 Tom

谢谢你的回答。最好给它添加一些描述和评论。 – Masoud

你是对的，但这是本周结束，我很懒。正如你打电话给我的，虽然我现在更新 – Tom

让我回答你的问题。只要客户专栏没有更新，它仍然被认为是第一行的客户（例如第1行到第3行是James）。我们正在尝试为每个客户查找重复项目。您的代码现在不能正常工作，但您的方法非常好。 – Masoud

如果你不想遍历所有的细胞，可以尝试像下面...

Sub ClearDuplicateItems() 
    Dim lr As Long 
    Application.ScreenUpdating = True 
    lr = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 
    Columns("G:H").Insert 
    Range("G2:G" & lr).Formula = "=INDEX(B$2:B2,MATCH(""zzz"",B$2:B2))" 
    Range("H2:H" & lr).Formula = "=IF(COUNTIFS(G$2:G2,INDEX(B$2:B2,MATCH(""zzz"",B$2:B2)),E$2:E2,E2)>1,NA(),"""")" 
    On Error Resume Next 
    Range("H2:H" & lr).SpecialCells(xlCellTypeFormulas, 16).Offset(0, -2).ClearContents 
    Range("H2:H" & lr).SpecialCells(xlCellTypeFormulas, 16).Offset(0, -3).ClearContents 
    Columns("G:H").Delete 
    Application.ScreenUpdating = True 
End Sub

来源

2017-04-01 05:58:51 sktneer

在Excel中清除内容的VBA代码

回答

相关问题