Excel 使用vba从3列宽的数据表中获取特定数据

我在A、B和C列中有一些数据。在A列中，我有识别号。对于彼此下方的某些行，这些项可以相同，但并不总是相同（也就是说，标识号1025只能在1行或10行中）。每个标识号在B列和C列中将有1个或多个条目。在B列中，有一些5位数字。每行可以相同，也可以不同。最后，在C列中，有一些短代码

我想从中得到的是B列中的一些数字。我想检查B列中是否有任何数字在C列中没有代码“HL”，并将它们放在D列中C列中“HL”的第一个条目旁边。如果有多个这样的数字，我仍然想将它们检索到D列中，用逗号分隔

一些例子：

A          B     C
1025001  11001   HL
1025001  11001   Sl
1025001  11002   ZF
1025001  11001   FG

在本例中，数字“11002”是从B列中检索的，因为它在C列中没有代码“HL”，并与具有相同标识符的第一个“HL”条目一起放入D列的行中

最终结果是：

A          B     C      D
1025001  11001   HL   11002
1025001  11001   Sl
1025001  11002   ZF
1025001  11001   FG

另一个具有更多行的示例：

A          B     C
1025001  11001   HL
1025001  11001   Sl
1025001  11002   ZF
1025001  11001   FG
2659856  26532   TU
2659856  26856   HL
2659856  26856   TU
3598745  34589   HL
3598745  36598   HL
4896523  48596   NK
4896523  49563   HL
4896523  41236   NK
4896523  41659   HL

结果是：

A          B     C      D
1025001  11001   HL   11002
1025001  11001   Sl
1025001  11002   ZF
1025001  11001   FG
2659856  26532   TU
2659856  26856   HL   26532
2659856  26856   TU
3598745  34589   HL
3598745  36598   HL
4896523  48596   NK
4896523  49563   HL   48596, 41236
4896523  41236   NK
4896523  41659   HL

对于第一个识别号1025001，11002的结果放在D列中，因为C列中没有该识别号的代码“HL”

对于第二行2659856，数字26532放入第二行，因为这是第一行，具有相同的识别号，代码为“HL”

对于第三行（3598745），没有条目，因为所有行都有代码“HL”

对于第四行，4896523，第二行有两个条目，因为这两个数字没有代码“HL”，并且第二行是第一个带有“HL”的条目

我试着自己写一个潜艇，但老实说，我甚至不知道如何开始。我已经用VBA编写了一些代码，但我没有足够的经验来编写这些代码。

一种方法：

子测试仪（）
尺寸vA、vB、vC、currA、rw作为范围、dict作为对象、rng作为范围、r作为长度、s、k
将ws设置为工作表
设置ws=ActiveSheet
设置rng=ws.Range（“A1”）.CurrentRegion的输入数据
设置rng=rng.Resize（rng.Rows.Count+1）”在下面包括一个空行以
'确保最后一个Id已记帐
currA=Chr（0）或任何不太可能的值。。。
r=0'给定Id的第一个“HL”行
对于rng.行中的每个rw
vA=rw.单元格（1）.值
vB=rw.单元格（2）.值
vC=rw.单元格（3）.值
如果是vA currA，则“可乐中的变化-记录任何以前的值”
如果Not dict为Nothing且r>0，则
s=“”
对于dict.key中的每个k
'只有没有关联HL的ColB编号
如果dict（k），则s=s&IIf（s“，”和“）&k
下一个k
ws.Cells（r，4）.Value=s
如果结束
currA=vA
r=0
Set dict=CreateObject（“scripting.dictionary”）
如果结束
'处理当前行
如果r=0且vC=“HL”，则r=rw.Row'记录第一个“HL”行号
如果不存在dict.exists（vB），则
说明添加vB，vC“HL”对/错
其他的
'取消'ColB编号，如果它有任何关联的HL
如果dict（vB）=True，则dict（vB）=vC“HL”
如果结束
下一个rw
端接头

写入不匹配项

选项显式
子写入匹配（）
“常数
常量srcFirstCell为String=“A1”
Const srcNumberOfColumns的长度=3
常量tgtFirstCell为String=“D1”
常量标准为String=“HL”
常量分隔符为String=“，”
变暗rng As范围
'定义最后一个单元格范围（'rng'）。
设置rng=单元格（Rows.Count，Range（srcFirstCell）.Column）_
.End（xlUp）.Offset（，srcNumberOfColumns-1）
'定义数据范围（'rng'）。
设置rng=范围（srcFirstCell，rng）
'定义数据数组（'数据'）。
作为变量的Dim数据
数据=平均值
'在第一列中写入唯一值及其出现次数
数据字典（'dict'）中的数据数组的。
作为对象的Dim dict
Set dict=CreateObject（“Scripting.Dictionary”）
我想我会坚持多久
对于i=1到uBond（数据，1）
dict（数据（i，1））=dict（数据（i，1））+1
下一个
'为每个下一个循环声明其他变量。
变暗键作为变量
黯淡的星空如长
暗尾行与长尾行相同
模糊的、统一的
Dim-HL作为变异体
Dim hlPos作为变体
长得一样暗
Dim ResultString作为字符串
'定义结果数组（'Result'）。
作为变量的模糊结果
重拨结果（1到UBound（数据，1），1到1）
对于dict.Keys中的每个键
'计算起始行（'StartRow'）。
StartRow=EndRow+1
'定义当前值的出现次数（'uniSize'）
'在数据数组的第一列中。
uniSize=dict（键）
'相应地调整HL数组的大小（'HL'）。
ReDim HL（1到uniSize）
'将值从第三列写入HL数组。
如果i=1，则为uniSize
HL（i）=数据（StartRow+i-1,3）
接下来我
'计算当前HL位置（'hlPos'）。
hlPos=应用程序匹配（标准，HL，0）
如果不是IsError（hlPos），则
“找到了。
'调整当前HL位置以适应数据数组中的位置。
hlPos=StartRow+hlPos-1
'从第二列定义当前HL值（'hlVal'）
数据数组的属性。
hlVal=数据（hlPos，2）
'初始化结果字符串（'ResultString'）。
结果字符串=“”
'计算结束行（'EndRow'）。
EndRow=StartRow+uniSize-1
'计算结果字符串。
对于i=从开始到结束行
'检查当前行是否不是HL行。
<code>
Option Explicit
Private Sub CommandButton1_Click()
Dim ws As Worksheet 'It's always wise to put your worksheet into a variable for reference. Much faster
Set ws = ActiveSheet 'Set it to the active sheet.

Dim ID As String '- To hold col A value
Dim IDCount As Integer '-To track how many of the same ID we have
Dim NewID As Boolean '-To track if we switch to a new ID
Dim Key() As String '-Array needed since we can have more than one HL Key per example 3
Dim KeyCount As Integer '-An index for the Key array
Dim Code As String '-To hold col C value
Dim Results As String '-To store the results for output when we finish the ID section.
Dim Match As Boolean '-To track key matches

Dim rng As Range '-This will be the entire range of the worksheet
'I'm hard setting it here for the example data for ease.
'You will want to code this to be more dynamic, of course
Set rng = ws.Range(ws.Cells(2, 1), ws.Cells(14, 4))

Dim Row As Integer, Col As Integer '-I always have Row & Col when working with worksheets.  Habit.
Dim i As Integer, j As Integer 'Index variables for looping and array reference

'Initialize veriables before the loop.
IDCount = 0 'Clearly we start our counts at zero
Results = "" 'And clearly we do not want anything in the results to start with.
For Row = 2 To 15
    If ws.Cells(Row, 1) <> ID Then NewID = True ''The very first row will always be a "new" id.
    If NewID Then
        'First output the results if any
        'Find the First HL coded Row
        For i = 0 To IDCount
            'Row is the current row, -IDCount will reference the first ID in the section.
            'This is why we track the IDCount.
            'Here we want to find the first instance of "HL" to put the results into.
            'All we are doing here is incrementing i until we find "HL"
            If ws.Cells(Row - IDCount + i, 3) = "HL" Then Exit For
        Next i
        'Row-IDCount+i will reference the first instance of "HL"
        If Results <> "" Then
            ws.Cells(Row - IDCount + i, 4) = Results 'Store the results here
            Results = ""
        End If
        'Since we are done with the IDCount from the previous section, clear it.
        IDCount = 0 'Setting to 1 because we are already on the first instance of the new ID
        NewID = False: KeyCount = 0
        ID = ws.Cells(Row, 1) 'Store the new ID value
        IDCount = IDCount + 1
        Code = ws.Cells(Row, 3) 'Store the code value
        ReDim Key(1) 'Initialize the array to have 1 element
        If Code = "HL" Then
            Key(KeyCount) = ws.Cells(Row, 2) 'Insert the new Key
        Else 'If Code <> "HL"
            If Results = "" Then
                Results = ws.Cells(Row, 2)
            Else ' Results <> ""
                Results = Results & ", " & ws.Cells(Row, 2)
            End If
        End If 'Code = "HL" or not
    Else 'If NOT NewID
        'Here we have data to compare.
        IDCount = IDCount + 1 'We have and additional row with the same ID
        If ws.Cells(Row, 3) = "HL" Then
            'Add a key to the array
            KeyCount = KeyCount + 1
            ReDim Preserve Key(KeyCount) 'Add an element to the array, keeping everything.
            Key(KeyCount) = ws.Cells(Row, 2)
        Else
            'Must loop through the section to check if non-"HL" cell matches any stored HL keys
            Match = False
            For j = 0 To KeyCount
                If Key(j) = ws.Cells(Row, 2) Then Match = True
            Next j
            If Match = False Then
                If Results = "" Then
                    Results = ws.Cells(Row, 2)
                Else
                    Results = Results & ", " & ws.Cells(Row, 2)
                End If 'Results = "" or not
            End If 'Match is true or false
        End If 'cell = "HL" or not
    End If 'NewID = true or false
Next Row