-1

我正在尝试为不匹配的对应值编写一个高效且更快的 VBA 代码，这将：

  • 对照 A1:A9000 检查 C 列的每个值
  • 如果找到：复制 B 列和 C 列的值并将它们粘贴到找到的单元格值（在 B 列和 C 列中），并删除旧的不匹配条目。

运行 for 循环最终会进行 9000*9000 计算，制作速度非常慢。我是初学者，不知道更快的方法。我知道 .Find 比使用 for 循环快很多。

以下是样本不匹配的数据：

A栏 B栏 C栏
XYZ1 对 XYZ1 的评论 XYZ1
XYZ3 对 XYZ2 的评论 XYZ2
XYZ5
XYZ6 对 XYZ4 的评论 XYZ4
XYZ8 对 XYZ5 的评论 XYZ5
XYZ9

请注意，B 列和 C 列中的值将始终相互匹配并正确对应。不匹配在A AND B & C之间。

这是期望的结果：

A栏 B栏 C栏
XYZ1 对 XYZ1 的评论 XYZ1
XYZ3
XYZ5 对 XYZ5 的评论 XYZ5
XYZ6
XYZ8
XYZ9

请注意，A 列不能更改或更改。

这是我到目前为止所拥有的，但处理代码需要的时间太长了：

Sub Realign()
For i = 2 To 9000
Set Found = Sheets("Sheet1").Range("A:A").Find(What:=Worksheets("Sheet1").Cells(i, 3).Value, _
                                                       LookIn:=xlValues, _
                                                       LookAt:=xlWhole, _
                                                       SearchOrder:=xlByRows, _
                                                       SearchDirection:=xlNext, _
                                                       MatchCase:=False)
        If Found Is Nothing Then
            Worksheets("Sheet1").Cells(i, 2).Value = ""
            Worksheets("Sheet1").Cells(i, 3).Value = ""
         
        Else
            Found.Offset(0, 1).Value = Worksheets("Sheet1").Cells(i, 2).Value
            Found.Offset(0, 2).Value = Worksheets("Sheet1").Cells(i, 3).Value
End If
Next
Call Delete1
End Sub

Sub Delete1()

For i = 2 To 9000

If Not Worksheets("Sheet1").Cells(i, 3).Value = Worksheets("Sheet1").Cells(i, 1).Value Then

    Worksheets("Sheet1").Cells(i, 2).Value = ""
    Worksheets("Sheet1").Cells(i, 3).Value = ""
 
End If
Next

End Sub
4

2 回答 2

1

Match()比 find 快：

编辑：重新工作以避免覆盖的机会（假设不存在重复项）

Sub Realign2()
    Dim ws As Worksheet, m, v, r As Long, arr, arr2
    Set ws = ThisWorkbook.Worksheets("Sheet2")
    
    arr = ws.Range("A1:C9000").Value 'get data as array
    
    arr2 = arr                       'make a copy
    
    'clear columns 2 and 3 in arr
    For r = 2 To UBound(arr, 1)
        arr(r, 2) = ""
        arr(r, 3) = ""
    Next r
    
    For r = 2 To UBound(arr2, 1)
        v = arr2(r, 3)
        If Len(v) > 0 Then
            m = Application.Match(v, ws.Range("A:A"), 0)
            If Not IsError(m) Then
                arr(m, 2) = arr2(r, 2)
                arr(m, 3) = arr2(r, 3)
            End If
        End If
    Next r
    ws.Range("A1:C9000").Value = arr
    
End Sub
于 2021-05-21T17:50:30.107 回答
0

这是一个 Power Query 解决方案。PQ 在 Windows Excel 2010+ 和 Office 365 中可用

要使用它：

  • 在数据表中选择一些单元格
  • Data => Get&Transform => from Table/Range
  • 当 PQ 编辑器打开时：Home => Advanced Editor
  • 记下第 2 行中的表名
  • 粘贴下面的 M 代码代替您看到的内容
  • 将第 2 行中的表名称更改回最初生成的名称。
  • 阅读评论并探索Applied Steps以了解算法

基本算法包括

  • 分成两个表 == 列 1 和合并列 2:3
  • 对表进行左外连接——这将保留一个表中的所有数据，并且只保留另一个表中的匹配行。

M代码

let
    Source = Excel.CurrentWorkbook(){[Name="Table6"]}[Content],

//split into two tables
    //Add index column to TblA for sorting back to original tblA order
    tblA = Table.SelectColumns(Source,"Column1"),
    #"Added Index" = Table.AddIndexColumn(tblA, "Index", 0, 1, Int64.Type),
    tblB = Table.SelectColumns(Source,{"Column2","Column3"}),

//rejoin using joinkind.leftouter -- retains only rows that exist in left side table (tblA)
    joined = Table.Join(#"Added Index","Column1",tblB,"Column3",JoinKind.LeftOuter),
    #"Sorted Rows" = Table.Sort(joined,{{"Index", Order.Ascending}}),
    #"Removed Columns" = Table.RemoveColumns(#"Sorted Rows",{"Index"})
in 
    #"Removed Columns"

在此处输入图像描述

编辑：对大约 9,000 行的虚构数据进行了测试，它在几分之一秒内运行。

于 2021-05-22T10:00:56.220 回答