Question

我在Excel中有以下数据。

CHM0123456  SRM0123:01  
CHM0123456  SRM0123:02  
CHM0123456  SRM0256:12  
CHM0123456  SRM0123:03  
CHM0123457  SRM0789:01  
CHM0123457  SRM0789:02  
CHM0123457  SRM0789:03  
CHM0123457  SRM0789:04

我需要做的是提取与单个CHM ref相关的所有相关SRM编号。现在我有一个公式，可以做这样的事情

=INDEX($C$2:$C$6, SMALL(IF($B$8=$B$2:$B$6, ROW($B$2:$B$6)-MIN(ROW($B$2:$B$6))+1, ""), ROW(A1)))

然而，这有点不整洁，我真的想用短vb脚本生成同样的东西，我是否必须正确运行一个循环并依次检查每一行。

For x = 1 to 6555
if Ax = Chm123456 
string = string + Bx
else
next

应该给我一个最后的字符串

SRM0123:01,SRM123:02,SRM0256:12,SRM0123:03

使用我想要的方式。

或者是一种更简洁的方法吗？

干杯

亚伦

我当前的代码

    For x = 2 To 6555
If Cells(x, 1).Value = "CHM0123456" Then
outstring = outstring + vbCr + Cells(x, 2).Value


End If


Next
MsgBox (outstring)

End Function

Answer 1

我不确定你对'整洁'的定义是什么，但这里有一个我认为非常整洁且灵活的VBA功能，并且它闪电般快（10k + entires没有滞后）。您将要查找的CHM传递给它，然后传递要查看的范围。您可以传递第三个可选参数，以设置每个条目的分隔方式。所以在你的情况下你可以写（假设你的列表是：

= ListUnique（B2，B2：B6555）

你也可以使用Char（10）作为第三个参数来按行分隔等分开

Function ListUnique(ByVal search_text As String, _
                    ByVal cell_range As range, _
                    Optional seperator As String = ", ") As String

Application.ScreenUpdating = False
Dim result As String
Dim i as Long
Dim cell As range
Dim keys As Variant
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")

On Error Resume Next
For Each cell In cell_range
    If cell.Value = search_text Then
        dict.Add cell.Offset(, 1).Value, 1
    End If
Next

keys = dict.keys
For i = 0 To UBound(keys)
    result = result & (seperator & keys(i))
Next

If Len(result) <> 0 Then
    result = Right$(result, (Len(result) - Len(seperator)))
End If

ListUnique = result
Application.ScreenUpdating = True

End Function

工作原理：简单地遍历您的范围，寻找您提供的search_string。如果找到它，它会将它添加到字典对象（这将消除所有欺骗）。您将结果转储到数组中，然后从中创建一个字符串。从技术上讲，如果你不确定列的末尾在哪里，你可以将“B：B”作为搜索数组传递，这个函数仍然可以正常工作（扫描B列中每个单元格的1/5秒）返回1000个唯一命中。）

Answer 2

另一个解决方案是为Chm123456做一个高级过滤器，然后你可以将它们复制到另一个范围。如果你在字符串数组中得到它们，你可以使用内置的excel函数Join（saString，“，”）（仅适用于字符串数组）。

不是您的实际代码，但它指出了可能有用的方向。

好的，这对于大量数据来说可能相当快。抓取每个单元格的数据需要花费大量时间，最好一次抓取所有数据。粘贴的唯一性，然后使用

抓取数据

vData=rUnique

其中vData是变体，rUnique是复制的单元格。这实际上可能比逐点抓取每个数据点更快（excel内部可以非常快速地复制和粘贴）。另一种选择是获取唯一数据，而无需复制和过去发生，具体如下：

dim i as long
dim runique as range, reach as range
dim sData as string
dim vdata as variant

set runique=advancedfilter(...) 'Filter in place
set runique=runique.specialcells(xlCellTypeVisible)
for each reach in runique.areas
 vdata=reach
 for i=lbound(vdata) to ubound(vdata)
  sdata=sdata & vdata(i,1)
 next l
next reach

就个人而言，我更喜欢内部复制粘贴，然后你可以浏览每个工作表，然后在最后抓取数据（这将非常快，比循环遍历每个单元格更快）。所以浏览每张表。

dim wks as worksheet

for each wks in Activeworkbook.Worksheets
 if wks.name <> "CopiedToWorksheet" then
  advancedfilter(...) 'Copy to bottom of list, so you'll need code for that
 end if 
next wks
vdata=activeworkbook.sheets("CopiedToWorksheet").usedrange
sData=vdata(1,1)
for i=lbound(vdata) + 1 to ubound(vdata)
 sData=sData & ","
next i

上面的代码应该非常快。我不认为你可以在一个变种上使用Join，但是你总是可以尝试它，这会使它更快。您还可以尝试使用application.worksheetfunctions.contat（或任何contatenate函数）来组合结果，然后只获取最终结果。

On Error Resume Next
 wks.ShowAllData
On Error GoTo 0
wks.UsedRange.Rows.Hidden = False
wks.UsedRange.Columns.Hidden = False
rFilterLocation.ClearContents

从Excel中的列中提取数据

2 个答案: