OPとして、VBA
タグが追加されました。この手順を試してください。 を対応する3 pieces
に分割し、リスト内の他のすべてのPositions
と比較します。 Positions
リストがB2
から始まり、比較結果を列C
にリストするとします。
'These Options declaration always go at the top of the module, class, etc.
Option Explicit
Option Base 1
Sub Get_Overlap()
Const kFlag As String = "Overlapping" 'Change as required
Dim rData As Range, aData As Variant, aResults() As String, sResult As String
Dim lA As Long, sAvalue As String, iAp As Integer, bA1 As Byte, bA2 As Byte
Dim lB As Long, sBvalue As String, iBp As Integer, bB1 As Byte, bB2 As Byte
Rem Sets Data Range & Arrays
With ThisWorkbook.Sheets("TEST").Columns("B") 'Change as required
Set rData = Range(.Cells(2), .Cells(Rows.Count).End(xlUp))
End With
aData = rData.Value2
aData = WorksheetFunction.Transpose(aData)
rData.Offset(0, 1).ClearContents
ReDim Preserve aResults(UBound(aData))
For lA = 1 To UBound(aData)
Rem Initialize & Set Item A Values
sAvalue = Empty: sAvalue = aData(lA)
iAp = 0: iAp = Left(sAvalue, 1)
bA1 = 0: bA1 = Mid(sAvalue, 3, 1)
On Error Resume Next
bA2 = 0: bA2 = Mid(sAvalue, 4, 1)
On Error GoTo 0
For lB = lA + 1 To UBound(aData)
Rem Initialize & Set Item B Values
sBvalue = Empty: sBvalue = aData(lB)
iBp = 0: iBp = Left(sBvalue, 1)
bB1 = 0: bB1 = Mid(sBvalue, 3, 1)
On Error Resume Next
bB2 = 0: bB2 = Mid(sBvalue, 4, 1)
On Error GoTo 0
Rem Initialize Comparison Result
sResult = Empty
Rem Compare Items & Values
Select Case True
Case sAvalue = sBvalue
sResult = kFlag
Case iAp = iBp
Select Case True
Case bA2 = 0 And bB2 = 0
If (bA1 = bB1) Then sResult = kFlag
Case bA2 = 0
If bA1 >= bB1 And bA1 <= bB2 Then sResult = kFlag
Case bB2 = 0
If bB1 >= bA1 And bB1 <= bA2 Then sResult = kFlag
Case Else
If bA1 >= bB1 And bA1 <= bB2 Then
sResult = kFlag
ElseIf bA2 >= bB1 And bA2 <= bB2 Then
sResult = kFlag
ElseIf bB1 >= bA1 And bB1 <= bA2 Then
sResult = kFlag
ElseIf bB2 >= bA1 And bB2 <= bA2 Then
sResult = kFlag
End If
End Select: End Select
Rem Add Results into Array
If sResult <> Empty Then
aResults(lA) = sResult
aResults(lB) = sResult
End If
Next: Next
Rem Enter Comparison Results
'Results will be posted one column to the right of where the List
'This is done by the use of "rData.Offset(0,1)"
rData.Offset(0, 1).Value = WorksheetFunction.Transpose(aResults)
End Sub
が使用するリソースのより深い理解を得るためには以下のページを読むことを提案する:
Option keyword、 Variables & Constants、 With Statement、 Range Object (Excel)、 WorksheetFunction Object (Excel)、 For...Next Statement、 Select Case Statement、 If...Then...Else Statement、 On Error Statement, Range.Offset Property (Excel)
出典
2016-10-26 10:52:41
EEM
ありがとうございました!どこのコードで私は列cを定義する必要がありますか?エクセルシートにポジション列がある新しい列が必要なのでしょうか? Option Explicit nadオプションBase 1はそうなるでしょうか? – Hankman3000
これで問題が解決する場合は、\タグを答えとして選択してください – EEM
1.コードは、リストがどこにあるか、つまりリストがBである場合は結果をCに掲載します。 'rData.Offset(0,1)'行目に置き換えます。あなたは何を指しているのか理解していない。オプションの宣言は常にモジュール、クラスなどの最上位にあります*(回答の編集を参照してください)* – EEM