使用 vba 从 3 列宽数据 table 中获取特定数据
Getting specific data from a 3 column wide data table using vba
我在 A、B 和 C 列中有一些数据。在 A 列中，我有标识号。对于彼此下方的某些行，这些可以相同，但并非总是如此（这意味着可以说标识号 1025 只能在 1 行或 10 行中。）每个标识号将在 B 列和 C 列中有 1 个或多个条目。在 B 列中，有一些 5 位数字。这些在每一行中可以相同，也可以不同。最后，在C栏，有一些短代码。
我想从中得到的是 B 列中的一些数字。我想检查 B 列中是否有任何数字，而 C 列中没有代码 'HL'，然后将它们在 C 列中 'HL' 的第一个条目旁边的 D 列中。如果有多个这样的数字，我仍然想将它们检索到 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' 的第一个条目。
我试过自己写一个 Sub，但老实说我什至不知道如何开始。我已经在 VBA 中编写了一些代码，但是我没有足够的经验。
一种方式：
Sub Tester()
Dim vA, vB, vC, currA, rw As Range, dict As Object, rng As Range, r As Long, s, k
Dim ws As Worksheet
Set ws = ActiveSheet
Set rng = ws.Range("A1").CurrentRegion 'input data
Set rng = rng.Resize(rng.Rows.Count + 1) 'include one empty row below to
' ensure the last Id is accounted for
currA = Chr(0) 'or any unlikely value...
r = 0 'the first "HL" row for a given Id
For Each rw In rng.Rows
vA = rw.Cells(1).Value
vB = rw.Cells(2).Value
vC = rw.Cells(3).Value
If vA <> currA Then 'Change in ColA - record any previous values
If Not dict Is Nothing And r > 0 Then
s = ""
For Each k In dict.keys
'only ColB numbers which had no associated HL
If dict(k) Then s = s & IIf(s <> "", ", ", "") & k
Next k
ws.Cells(r, 4).Value = s
End If
currA = vA
r = 0
Set dict = CreateObject("scripting.dictionary")
End If
'process the current row
If r = 0 And vC = "HL" Then r = rw.Row 'record first "HL" row number
If Not dict.exists(vB) Then
dict.Add vB, vC <> "HL" 'True/False
Else
' "cancel" ColB number if it has any associated HL
If dict(vB) = True Then dict(vB) = vC <> "HL"
End If
Next rw
End Sub
写入不匹配
Option Explicit
Sub writeNoMatch()
' Constants
Const srcFirstCell As String = "A1"
Const srcNumberOfColumns As Long = 3
Const tgtFirstCell As String = "D1"
Const Criteria As String = "HL"
Const Delimiter As String = ", "
Dim rng As Range
' Define Last Cell Range ('rng').
Set rng = Cells(Rows.Count, Range(srcFirstCell).Column) _
.End(xlUp).Offset(, srcNumberOfColumns - 1)
' Define Data Range ('rng').
Set rng = Range(srcFirstCell, rng)
' Define Data Array ('Data').
Dim Data As Variant
Data = rng.Value
' Write the unique values and their number of occurrences in first column
' of Data Array to the Data Dictionary ('dict').
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim i As Long
For i = 1 To UBound(Data, 1)
dict(Data(i, 1)) = dict(Data(i, 1)) + 1
Next
' Declare additional variables for the For Each Next loop.
Dim Key As Variant
Dim StartRow As Long
Dim EndRow As Long
Dim uniSize As Long
Dim HL As Variant
Dim hlPos As Variant
Dim hlVal As Long
Dim ResultString As String
' Define Result Array ('Result').
Dim Result As Variant
ReDim Result(1 To UBound(Data, 1), 1 To 1)
For Each Key In dict.Keys
' Calculate Start Row ('StartRow').
StartRow = EndRow + 1
' Define the number of occurrences ('uniSize') of the current value
' in first column of Data Array.
uniSize = dict(Key)
' Resize HL Array ('HL') accordingly.
ReDim HL(1 To uniSize)
' Write values from third column to HL Array.
For i = 1 To uniSize
HL(i) = Data(StartRow + i - 1, 3)
Next i
' Calculate the current HL Position ('hlPos').
hlPos = Application.Match(Criteria, HL, 0)
If Not IsError(hlPos) Then
' hlPos found.
' Adjust current HL Position to fit position in Data Array.
hlPos = StartRow + hlPos - 1
' Define current HL Value ('hlVal') from the second column
' of Data Array.
hlVal = Data(hlPos, 2)
' Initialize Resulting String ('ResultString').
ResultString = ""
' Calculate End Row ('EndRow').
EndRow = StartRow + uniSize - 1
' Calculate Resulting String.
For i = StartRow To EndRow
' Check if current row is not the HL row.
If i <> hlPos Then
' Check if current value in second column is different than
' HL Value.
If Data(i, 2) <> hlVal Then
' Check if current value in third column is different
' than Criteria.
If Data(i, 3) <> Criteria Then
' Write Result String.
ResultString = ResultString & Delimiter _
& CStr(Data(i, 2))
End If
End If
End If
Next
' Write Resulting String to Result Array ('Result').
If ResultString <> "" Then
Result(hlPos, 1) = Right(ResultString, Len(ResultString) _
- Len(Delimiter))
End If
Else
' hlPos not found.
End If
Next Key
' Write values from Result Array to Target Column Range.
Range(tgtFirstCell).Resize(UBound(Data)).Value = Result
' Inform user.
MsgBox "No-match data transferred.", vbInformation, "Success"
End Sub
我将把这个解决方案混合在一起只是为了提供不同的视角。这段代码当然不是最有效的，但我想展示的是如何构建算法。基本上只是从你在脑海中如何做开始。你在问题的最初解释中写下规则，从那里开始构建。你知道你将不得不遍历每一行。接下来开始构建 If/Then 比较。您将 运行 陷入“初始值”问题，这意味着当没有可比较的内容时如何处理循环的第一个 运行。你想怎么处理？有时一个简单的“if first 运行through then”就是答案，有时——正如我在这里所做的——你可以简单地假装它是一个像其他任何循环一样的循环。也许当你循环浏览时，你可能会遇到其他没有什么可比较的实例。
一旦代码全部构建并运行（就像我在这里所做的那样），您就可以返回并进行优化。也许使用字典或数组更好。也许构建一个 class 是值得的。这一切都取决于。但是当你遇到这样的事情时，只要开始写下 pseudo-code 就可以模仿你在评估你写下的规则时所做的事情。
下面是适用于您的问题的代码。正如我所说，它不是最有效的，它只是我在做上面刚刚描述的事情时突然想到的。我希望这有助于演示一种生成算法的方法。
<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
结束子'CommandButton1_Click
我在 A、B 和 C 列中有一些数据。在 A 列中，我有标识号。对于彼此下方的某些行，这些可以相同，但并非总是如此（这意味着可以说标识号 1025 只能在 1 行或 10 行中。）每个标识号将在 B 列和 C 列中有 1 个或多个条目。在 B 列中，有一些 5 位数字。这些在每一行中可以相同，也可以不同。最后，在C栏，有一些短代码。
我想从中得到的是 B 列中的一些数字。我想检查 B 列中是否有任何数字，而 C 列中没有代码 'HL'，然后将它们在 C 列中 'HL' 的第一个条目旁边的 D 列中。如果有多个这样的数字，我仍然想将它们检索到 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' 的第一个条目。
我试过自己写一个 Sub，但老实说我什至不知道如何开始。我已经在 VBA 中编写了一些代码，但是我没有足够的经验。
一种方式：
Sub Tester()
Dim vA, vB, vC, currA, rw As Range, dict As Object, rng As Range, r As Long, s, k
Dim ws As Worksheet
Set ws = ActiveSheet
Set rng = ws.Range("A1").CurrentRegion 'input data
Set rng = rng.Resize(rng.Rows.Count + 1) 'include one empty row below to
' ensure the last Id is accounted for
currA = Chr(0) 'or any unlikely value...
r = 0 'the first "HL" row for a given Id
For Each rw In rng.Rows
vA = rw.Cells(1).Value
vB = rw.Cells(2).Value
vC = rw.Cells(3).Value
If vA <> currA Then 'Change in ColA - record any previous values
If Not dict Is Nothing And r > 0 Then
s = ""
For Each k In dict.keys
'only ColB numbers which had no associated HL
If dict(k) Then s = s & IIf(s <> "", ", ", "") & k
Next k
ws.Cells(r, 4).Value = s
End If
currA = vA
r = 0
Set dict = CreateObject("scripting.dictionary")
End If
'process the current row
If r = 0 And vC = "HL" Then r = rw.Row 'record first "HL" row number
If Not dict.exists(vB) Then
dict.Add vB, vC <> "HL" 'True/False
Else
' "cancel" ColB number if it has any associated HL
If dict(vB) = True Then dict(vB) = vC <> "HL"
End If
Next rw
End Sub
写入不匹配
Option Explicit
Sub writeNoMatch()
' Constants
Const srcFirstCell As String = "A1"
Const srcNumberOfColumns As Long = 3
Const tgtFirstCell As String = "D1"
Const Criteria As String = "HL"
Const Delimiter As String = ", "
Dim rng As Range
' Define Last Cell Range ('rng').
Set rng = Cells(Rows.Count, Range(srcFirstCell).Column) _
.End(xlUp).Offset(, srcNumberOfColumns - 1)
' Define Data Range ('rng').
Set rng = Range(srcFirstCell, rng)
' Define Data Array ('Data').
Dim Data As Variant
Data = rng.Value
' Write the unique values and their number of occurrences in first column
' of Data Array to the Data Dictionary ('dict').
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim i As Long
For i = 1 To UBound(Data, 1)
dict(Data(i, 1)) = dict(Data(i, 1)) + 1
Next
' Declare additional variables for the For Each Next loop.
Dim Key As Variant
Dim StartRow As Long
Dim EndRow As Long
Dim uniSize As Long
Dim HL As Variant
Dim hlPos As Variant
Dim hlVal As Long
Dim ResultString As String
' Define Result Array ('Result').
Dim Result As Variant
ReDim Result(1 To UBound(Data, 1), 1 To 1)
For Each Key In dict.Keys
' Calculate Start Row ('StartRow').
StartRow = EndRow + 1
' Define the number of occurrences ('uniSize') of the current value
' in first column of Data Array.
uniSize = dict(Key)
' Resize HL Array ('HL') accordingly.
ReDim HL(1 To uniSize)
' Write values from third column to HL Array.
For i = 1 To uniSize
HL(i) = Data(StartRow + i - 1, 3)
Next i
' Calculate the current HL Position ('hlPos').
hlPos = Application.Match(Criteria, HL, 0)
If Not IsError(hlPos) Then
' hlPos found.
' Adjust current HL Position to fit position in Data Array.
hlPos = StartRow + hlPos - 1
' Define current HL Value ('hlVal') from the second column
' of Data Array.
hlVal = Data(hlPos, 2)
' Initialize Resulting String ('ResultString').
ResultString = ""
' Calculate End Row ('EndRow').
EndRow = StartRow + uniSize - 1
' Calculate Resulting String.
For i = StartRow To EndRow
' Check if current row is not the HL row.
If i <> hlPos Then
' Check if current value in second column is different than
' HL Value.
If Data(i, 2) <> hlVal Then
' Check if current value in third column is different
' than Criteria.
If Data(i, 3) <> Criteria Then
' Write Result String.
ResultString = ResultString & Delimiter _
& CStr(Data(i, 2))
End If
End If
End If
Next
' Write Resulting String to Result Array ('Result').
If ResultString <> "" Then
Result(hlPos, 1) = Right(ResultString, Len(ResultString) _
- Len(Delimiter))
End If
Else
' hlPos not found.
End If
Next Key
' Write values from Result Array to Target Column Range.
Range(tgtFirstCell).Resize(UBound(Data)).Value = Result
' Inform user.
MsgBox "No-match data transferred.", vbInformation, "Success"
End Sub
我将把这个解决方案混合在一起只是为了提供不同的视角。这段代码当然不是最有效的，但我想展示的是如何构建算法。基本上只是从你在脑海中如何做开始。你在问题的最初解释中写下规则，从那里开始构建。你知道你将不得不遍历每一行。接下来开始构建 If/Then 比较。您将 运行 陷入“初始值”问题，这意味着当没有可比较的内容时如何处理循环的第一个 运行。你想怎么处理？有时一个简单的“if first 运行through then”就是答案，有时——正如我在这里所做的——你可以简单地假装它是一个像其他任何循环一样的循环。也许当你循环浏览时，你可能会遇到其他没有什么可比较的实例。
一旦代码全部构建并运行（就像我在这里所做的那样），您就可以返回并进行优化。也许使用字典或数组更好。也许构建一个 class 是值得的。这一切都取决于。但是当你遇到这样的事情时，只要开始写下 pseudo-code 就可以模仿你在评估你写下的规则时所做的事情。
下面是适用于您的问题的代码。正如我所说，它不是最有效的，它只是我在做上面刚刚描述的事情时突然想到的。我希望这有助于演示一种生成算法的方法。
<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
结束子'CommandButton1_Click