在Excel中从列表中提取数据
我在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参考相关的相关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
这应该给我一个最后的string
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
我不确定你对“整齐”的定义是什么，但是这里有一个VBAfunction，我认为它非常整齐，灵活，并且闪电般快（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。 如果find它，它将它添加到一个字典对象（这将消除所有愚蠢）。 将结果转储到数组中，然后从中创build一个string。 从技术上讲，如果您不确定列的末尾在哪里，那么您可以将它传递给“B：B”作为search数组，并且此函数仍然可以正常工作（扫描B列中每个单元的1/5秒有1000个独特的命中返回）。
另一个解决scheme是为Chm123456做一个高级filter，然后你可以将这些复制到另一个范围。 如果你把它们放在一个string数组中，你可以使用内置的excel函数Join（saString，“，”）（仅适用于string数组）。
不是针对你的实际代码，而是指向你可能有用的方向。
好吧，对于大量数据来说这可能相当快。 抓取每个单元格的数据需要花费大量的时间，最好一次抓住它。 独一无二的粘贴然后抓取数据使用
vData=rUnique
其中vData是变体，rUnique是复制的单元格。 这实际上可能比逐点抓取每个数据点更快（Excel内部可以复制和粘贴非常快）。 另一种select是在没有复制和过去的情况下获取唯一的数据，方法如下：
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