繁体   English   中英

VBA比较两个Excel行并删除相似的单元格

[英]VBA Comparing two excel rows and deleting similar cells

我正在尝试制作一个Excel代码,该代码将比较同一工作表的第1行和第2行的使用范围,并删除任何相似的单元格,并将其余的(唯一值)单元格从A1开始移至第1行。

例如)如果第1行包含以下值(用逗号分隔diff单元格):a,b,c,第2行包含:a,b,c,d,e

我希望代码比较两行,并在代码完成后以1,d(在A和B列中)结束第一行。 任何帮助,将不胜感激。

我是VBA的新手,所以在某些语法上遇到麻烦,如果某些专业人士可以帮助我,我将不胜感激。

  1. 获取第1行和第2行使用的列数(整数)。 例如)maxCol1 = 3,maxCol2 = 5

  2. 创建一个从i = 1到maxCol2的for循环,并将第1行与第2行进行比较。如果它们相等,则将它们都设为“”,如果第2行中有东西但第1行中没有,则将该值设置为单元格A1 。

基本上只需要设置步骤1的帮助。

借助评论中发布的链接,我知道了! 感谢那些帮助。 该代码将比较第1行中的第2行,并删除任何相似的单元格值,并将唯一值发布到第1行以及新工作表中。

 Sub CompareAndDelete()
'This code will compare the rows of each sheet and delete any old alerts that have already been emailed out
'   it will then call SaveFile IF new alerts have been found

Dim row1() As Variant, row2() As Variant, newRow As Variant
Dim coll As Collection
Dim i As Long
Dim maxCol1 As Integer
Dim maxCol2 As Integer

'Find max number of columns for old and new alert
With ActiveSheet
    maxCol1 = .Cells(1, .Columns.Count).End(xlToLeft).Column
    maxCol2 = .Cells(2, .Columns.Count).End(xlToLeft).Column
End With

'Redimensionalize arrays
ReDim row1(0 To (maxCol1 - 1))
ReDim row2(0 To (maxCol2 - 1))

'Assign row1/row2 string values into arrays
For r = 0 To (maxCol1 - 1)
   row1(r) = Cells(1, r + 1).Value
Next

For s = 0 To (maxCol2 - 1)
    row2(s) = Cells(2, s + 1).Value
Next

ReDim newRow(LBound(row1) To Abs(UBound(row2) - UBound(row1)) - 1)

'Create a collection to load all row1/row2 values into
Set coll = New Collection

'Empty Collection for each run through
Set coll = Nothing

'Set collection to New before using
Set coll = New Collection



For i = LBound(row1) To (UBound(row1))
    coll.Add row1(i), row1(i)
Next i

For i = LBound(row2) To (UBound(row2))
    On Error Resume Next
    coll.Add row2(i), row2(i)
    If Err.Number <> 0 Then
        coll.Remove row2(i)
    End If
    On Error GoTo 0
Next i

'Copy Row 2 and Paste it to Row 1

ActiveWorkbook.ActiveSheet.Rows(2).Copy
Range("A1").Select
ActiveSheet.Paste

'Now values are stored in collection, delete row 2
'Rows(2).EntireRow.ClearContents

'Paste only the new alerts onto a new worksheet that is designated for new   alerts
For i = LBound(newRow) To UBound(newRow)
    newRow(i) = coll(i + 1) 'Collections are 1-based
    'Debug.Print newRow(i)
    ActiveWorkbook.Sheets("Sheet" & index + 4).Select
    ActiveWorkbook.Sheets("Sheet" & index + 4).Cells(1, i + 1).Value =   newRow(i)

Next i


'if NEW alerts have been found, call SaveFile
If IsEmpty(ActiveWorkbook.Sheets("Sheet" & index + 4).Cells(1, 1)) = False     Then
         Call SaveFile
End If

End Sub
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

暂无
暂无

声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM