我有一個范圍串列和一個 excel 單元格的排除串列。我想制作一個考慮到排除項的新范圍串列。請注意，第一個條目始終是下限，第二個條目始終是上限。有時，排除項和范圍內的單元格之間都有空格。這是一個以黑色給出的代碼輸出示例
代碼如下，請注意，帶有 msg 框的引號行之間的所有內容只是為了您的方便（錯誤測驗）。想必離得不遠了，我覺得問題是代碼需要前瞻性？另外，我猜共享 Excel 表違反了社區準則。
編輯：我被要求更全面地解釋邏輯，所以我把它放在這里。第一個排除范圍是 111000222-111000333，通常這意味著較大的范圍會在 111000221 停止，然后在 1110003334 再次上升。
但是由于下一個排除范圍是 111000334 到 111000444，那么我們必須從第二個排除范圍的末尾開始，即 111000445。這是因為第一個排除范圍的上限 1 等于第二個排除范圍的下限范圍。
''
Sub Macro2()
'
' Macro2 Macro
'
Dim inrange As Range, outrange As Range, current As Range, goodcell As Range, badcell As Range, w As Integer
'counter for inrange loop
k = 1
'counter for outrange loop
c = 1
'Current X coordinate
Row = 13
Column = 5
Range("A13:CW13").Clear
Set inrange = Range("E7:BL7")
Set outrange = Range("E9:BV9")
Set current = Cells(Row, Column)
For Each goodcell In inrange
If Len(goodcell.Value) = 9 And k = 1 Then
lower_range = goodcell.Value
''''''''''''''''''''''''''''''''''''''
Cells(17, 3) = lower_range
MsgBox "Step 1"
''''''''''''''''''''''''''''''''''''''
k = 2
ElseIf Len(goodcell.Value) = 9 And k = 2 Then
upper_range = goodcell.Value
''''''''''''''''''''''''''''''''''''''
Cells(17, 5) = upper_range
MsgBox "Step 2"
''''''''''''''''''''''''''''''''''''''
For Each badcell In outrange
If Len(badcell) = 9 And c = 1 Then
blower_range = badcell.Value
''''''''''''''''''''''''''''''''''''''
Cells(17, 4) = blower_range
MsgBox "Step 3"
''''''''''''''''''''''''''''''''''''''
c = 2
ElseIf Len(badcell.Value) = 9 And c = 2 Then
bupper_range = badcell.Value
''''''''''''''''''''''''''''''''''''''
Cells(17, 6) = bupper_range
MsgBox "Step 4"
''''''''''''''''''''''''''''''''''''''
If upper_range > bupper_range And lower_range < blower_range And blower_range < bupper_range And old_bupper_range 1 <> blower_range Then
current.Value = lower_range
''''''''''''''''''''''''''''''''''''''
Cells(17, 7) = current.Value
MsgBox "Step 5"
''''''''''''''''''''''''''''''''''''''
Column = Column 1
Set current = Cells(Row, Column) 'to the right
If lower_range <> old_bupper_range Then
current.Value = blower_range - 1
Column = Column 1
Set current = Cells(Row, Column) 'to the right
End If
''''''''''''''''''''''''''''''''''''''
Cells(17, 7) = current.Value
MsgBox "Step 6"
''''''''''''''''''''''''''''''''''''''
old_bupper_range = bupper_range 1
lower_range = bupper_range 1
''''''''''''''''''''''''''''''''''''''
Cells(17, 2) = old_bupper_range
Cells(17, 3) = lower_range
MsgBox "Step 7"
''''''''''''''''''''''''''''''''''''''
c = 1
End If
End If
Next badcell
If lower_range <> blower_range Then
current.Value = lower_range
Column = Column 1
Set current = Cells(Row, Column) 'to the right
End If
''''''''''''''''''''''''''''''''''''''
Cells(17, 7) = current.Value
MsgBox "Step 8"
''''''''''''''''''''''''''''''''''''''
current.Value = upper_range
''''''''''''''''''''''''''''''''''''''
Cells(17, 7) = current.Value
MsgBox "Step 9"
''''''''''''''''''''''''''''''''''''''
Column = Column 1
Set current = Cells(Row, Column) 'to the right
k = 1
End If
Next goodcell
'
End Sub
''
uj5u.com熱心網友回復：
這種方法會先結合連續范圍，這樣就可以直接從每個例外范圍計算結果。
類模塊 - clsNumberRange
Public Lower As Long
Public Upper As Long
標準模塊
Sub Test()
'Collate range pairs into collection
Const firstCol As Long = 5 '= E, starting column number for all 3 lists
Const clearCol As Long = 101 '= CW, last column to clear content
Const inputRow As Long = 7
Const excepRow As Long = 9
Const resultRow As Long = 13
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'Change the worksheet as needed
'Collate input range into collection
Dim inputColl As Collection
Set inputColl = GetNumberRanges(inputRow, firstCol, ws)
'Collate exception pairs into collection
Dim excepColl As Collection
Set excepColl = GetNumberRanges(excepRow, firstCol, ws)
Dim resultColl As Collection
Set resultColl = New Collection
Dim resultPair As clsNumberRange
Dim i As Long
Dim n As Long
Dim startExcep As Long
For n = 1 To inputColl.Count
'Find the first exception range that fits into current input range
Set resultPair = New clsNumberRange
resultPair.Lower = inputColl(n).Lower
For startExcep = 1 To excepColl.Count
If inputColl(n).Lower < excepColl(startExcep).Lower Then
resultPair.Upper = excepColl(startExcep).Lower - 1
Exit For
End If
Next startExcep
resultColl.Add resultPair
'Start getting result range outside from the remaining exception range
For i = startExcep 1 To excepColl.Count
Set resultPair = New clsNumberRange
resultPair.Lower = excepColl(i - 1).Upper 1
If excepColl(i).Lower < inputColl(n).Upper Then
resultPair.Upper = excepColl(i).Lower - 1
Else
resultPair.Upper = inputColl(n).Upper
resultColl.Add resultPair
Exit For
End If
resultColl.Add resultPair
Next i
'If the last exception range is smaller than current input range then add another range into the result
If inputColl(n).Upper > excepColl(excepColl.Count).Upper Then
Set resultPair = New clsNumberRange
resultPair.Lower = excepColl(excepColl.Count).Upper 1
resultPair.Upper = inputColl(n).Upper
resultColl.Add resultPair
End If
Next n
Dim outputSize As Long
outputSize = resultColl.Count * 2
Dim outputArr() As Long
ReDim outputArr(1 To 1, 1 To outputSize) As Long
Dim resultCount As Long
resultCount = 1
For i = 1 To UBound(outputArr, 2) Step 2
outputArr(1, i) = resultColl(resultCount).Lower
outputArr(1, i 1) = resultColl(resultCount).Upper
resultCount = resultCount 1
Next i
ws.Range(ws.Cells(resultRow, firstCol), ws.Cells(resultRow, clearCol)).Clear
ws.Cells(resultRow, firstCol).Resize(, UBound(outputArr, 2)).Value = outputArr
End Sub
Private Function GetNumberRanges(inputRow As Long, inputStartCol As Long, ws As Worksheet) As Collection
Dim inputLastCol As Long
inputLastCol = ws.Cells(inputRow, ws.Columns.Count).End(xlToLeft).Column
Dim inputArr As Variant
inputArr = ws.Range(ws.Cells(inputRow, inputStartCol), ws.Cells(inputRow, inputLastCol)).Value
Dim outputPairs As clsNumberRange
Dim outputColl As Collection
Set outputColl = New Collection
Dim i As Long
i = 1
Do While i < UBound(inputArr, 2)
If inputArr(1, i) <> vbNullString And inputArr(1, i 1) <> vbNullString Then
'Allocate range in pairs into the collection
Set outputPairs = New clsNumberRange
With outputPairs
.Lower = inputArr(1, i)
.Upper = inputArr(1, i 1)
End With
outputColl.Add outputPairs
i = i 1
End If
i = i 1
Loop
CollatePairs outputColl
Set GetNumberRanges = outputColl
Erase inputArr
End Function
Private Sub CollatePairs(argColl As Collection)
If argColl.Count <> 1 Then
Dim i As Long
i = 1
Do While i < argColl.Count
'If the current range is continous from the next range, merge the range and discard next range from the collection
Do While argColl(i).Upper 1 = argColl(i 1).Lower
argColl(i).Upper = argColl(i 1).Upper
argColl.Remove i 1
If i = argColl.Count Then Exit Do
Loop
i = i 1
Loop
End If
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/houduan/351868.html
上一篇：在Excel中查詢另一個表
下一篇：添加gradle依賴項