问题描述
我在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
在这种情况下，从列B检索数字“ 11002”，因为它在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
我将把这个解决方案加入到混合中以给出不同的观点。这段代码当然不是最有效的，但是我试图展示的是如何构建算法。基本上只是从脑子里做起。您在问题的初始解释中放下了规则，从那里开始构建。您知道您将不得不遍历每一行。接下来，您开始构建“如果/那么”比较。您将遇到“初始值”问题，这意味着在没有任何可比较的情况下第一次循环运行。您要如何处理？有时，一个简单的“如果先经过，然后”便是答案，就像我在这里所做的那样，有时，您可以简单地假装这是一个循环，就像其他循环一样。也许当您遍历时，您可能会遇到其他没有什么可比较的实例。
一旦代码全部构建并可以正常工作（如我在此处所示），您就可以重新进行优化。也许使用字典或数组会更好。也许建立一个班级值得做。一切都取决于。但是，当您遇到这样的事情时，只需开始放下伪代码，该伪代码就可以模拟您评估放下的规则时所做的事情。
下面是适合您的问题的代码。正如我所说的，这并不是最有效的，这只是我在做上面刚刚描述的事情时鞭打的。我希望这有助于演示一种产生编码算法的方法。
<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,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 & ",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
End Sub'CommandButton1_Click