如果其他列中的第一个整数或第一个和第三个整数匹配，则VBA代码可连接列中的字符串

如何解决如果其他列中的第一个整数或第一个和第三个整数匹配，则VBA代码可连接列中的字符串

好的，这是一个非常具体的问题。我编写了一个excel宏，该宏接受一个Web URL，对其进行定界，对其进行转置，然后在原始转置的列中添加用于描述信息的相邻列。现在，我需要在宏中添加一些内容，这些宏将循环通过并检查一个单元格的第一个字符是否与另一个单元格的前四个字符之一匹配。如果是这样，我需要将字符串从描述性列连接到新单元格。我将在下面说明这一点：


3,435,201,0.5,%22type%25202%2520diabetes%22,0   Node    type 2 diabetes
4,165,97,%22diet%22,0                       Node    diet
5,149,248,%22lack%2520of%2520exercise%22,2  Node    lack of exercise
6,289,329,%22genetics%22,3                  Node    genetics
7,300,71,%22blood%2520pressure%2520%22,5    Node    blood pressure 
7,3,-7,1,0                                      Arrow   +
4,-21,0                                     Arrow   +
5,-22,0                                     Arrow   +
6,-34,0                                     Arrow   +,7%5D                                           Tail

我添加了颜色，使问题的概念更容易形象化。在第一列的第一行中，我们看到对应于“ 2型糖尿病”的红色3。在第一列的第五行中，我们看到对应于“血压”的蓝色7。这些都是节点对象，如相邻列所示。在第一列的第六个单元格中，我们看到蓝色7和红色3。这表明箭头（也由相邻的列表示）将血压与糖尿病联系起来。在下一列中，我们看到一个橙色加号，表示这是正向关系。

目标是在下一栏填充“血压+糖尿病”，如图所示。因此，我需要一些代码来检查每个节点单元格中的第一个字符，然后将它们与每个箭头单元格的前4个字符进行比较。当找到与两个节点匹配的箭头时，我需要代码用连接字符串填充+号旁边的行，该字符串由与该箭头有关的节点的名称以及它们之间的+号组成（可能也可能是减号，但在此示例中不存在）。有指针吗？我无法解决这个问题。 已编辑以添加数据

这是我当前宏的代码：

Sub Delimit_Transpose()
    
    Cells.Replace What:="],[",Replacement:="@",LookAt:=xlPart,SearchOrder _
        :=xlByRows,MatchCase:=False,SearchFormat:=False,ReplaceFormat:=False
    
    ActiveCell.FormulaR1C1 = "=RIGHT(R[-1]C,LEN(R[-1]C)-36)"
    
    Dim i As Long,strTxt As String
    Dim startP As Range
    Dim xRg As Range,yRg As Range
    On Error Resume Next
    Set xRg = Application.InputBox _
    (Prompt:="Range Selection...",_
    Title:="Delimit Transpose",Type:=8)
    i = 1
    Application.ScreenUpdating = False
    For Each yRg In xRg
        If i = 1 Then
            strTxt = yRg.Text
            i = 2
        Else
            strTxt = strTxt & "," & yRg.Text
        End If
    Next
    Application.ScreenUpdating = True
    Set startP = Application.InputBox _
    (Prompt:="Paste Range...",Type:=8)
    ary = Split(strTxt,"@")
    i = 1
    Application.ScreenUpdating = False
    For Each a In ary
        startP(i,1).Value = Replace(Replace(a,"[",""),"]","")
        i = i + 1
    Next a
    
    i = 1
    For Each a In ary
       If Len(a) > 13 Then
           startP.Offset(i - 1,1).Value = "Node"
        ElseIf Len(a) < 13 And Len(a) > 6 Then
            startP.Offset(i - 1,1).Value = "Arrow"
        Else
            startP.Offset(i - 1,1).Value = "Tail"
        End If
        i = i + 1
    Next a

    Dim openPos As Integer
    Dim closePos As Integer
    Dim midBit As String
    
    i = 1
    n = 5
    For Each a In ary
    openPos = InStr(a,",%22")
     On Error Resume Next
    closePos = InStr(a,"%22,")
     On Error Resume Next
    midBit = Mid(a,openPos + 1,closePos - openPos - 1)
     On Error Resume Next
        If openPos <> 0 And Len(midBit) > 0 Then
            startP.Offset(i - 1,2).Value = Replace(Replace(midBit,"%22","%2520"," ")
        ElseIf Len(a) < 13 And InStr(a,"-") = 4 Then
            startP.Offset(i - 1,2).Value = "'-"
        ElseIf Len(a) < 7 Then
            startP.Offset(i - 1,2).Value = " "
        Else
            startP.Offset(i - 1,2).Value = "+"
        End If
        i = i + 1
        n = n + 1
    Next a

    Application.ScreenUpdating = True
End Sub

解决方法

这是我的方法。

a lot of improvements尚有空间，但是这是一个入门的粗略代码。

阅读代码的注释，并使其适应您的需求。

编辑：我更新了代码以匹配您上载的示例工作表，以动态方式构建第一列范围，验证逗号是否出现在第一列单元格中，从而不会引发错误。

正如我在评论中所说，~~如果您从另一个过程中调用一个过程而不是合并它们，则更容易调试~~。

代码：

Option Explicit

Public Sub StoreConcatenate()

    ' Basic error handling
    On Error GoTo CleanFail
    
    ' Define general parameters
    Dim targetSheetName As String
    targetSheetName = "Test space" ' Sheet holding the data
    
    Dim firstColumnLetter As String
    firstColumnLetter = "C" ' First column holding the numbers
    
    Dim firstColumnStartRow As Long
    firstColumnStartRow = 7
    
    ' With these three parameters we'll build the range address holding the first column dynamically
    
    ' Set reference to worksheet
    Dim targetSheet As Worksheet
    Set targetSheet = ThisWorkbook.Worksheets(targetSheetName)
    
    ' Find last row in column (Modify on what column)
    Dim firstColumnlastRow As Long
    firstColumnlastRow = targetSheet.Cells(targetSheet.Rows.Count,firstColumnLetter).End(xlUp).Row
    
    ' Build range of first column dinamically
    Dim firstColumnRange As Range
    Set firstColumnRange = targetSheet.Range(firstColumnLetter & firstColumnStartRow & ":" & firstColumnLetter & firstColumnlastRow)
    
    ' Loop through first column range cells
    Dim valueCell As Range
    For Each valueCell In firstColumnRange
        
        ' Check if cell contains "," in the second position in string
        If InStr(valueCell.Value,",") = 2 Then
        
            ' Store first digit of cell before ","
            Dim firstDigit As Integer
            firstDigit = Split(valueCell.Value,")(0)
            
            
            ' Check if cell contains "," in the fourth position in string
            If InStr(3,valueCell.Value,") = 4 Then
            
                ' Store second digit of cell after ","
                Dim secondDigit As Integer
                secondDigit = Split(valueCell.Value,")(1)
            
            End If
            
            ' Store second colum type
            Dim secondColumnType As String
            secondColumnType = valueCell.Offset(,1).Value
            
            ' Store third column value
            Dim thirdColumnValue As String
            thirdColumnValue = valueCell.Offset(,2).Value
            
            ' Store nodes values (first digit and second column type)
            Select Case secondColumnType
            Case "Node"
                Dim nodeValues() As Variant
                Dim nodeCounter As Long
                ReDim Preserve nodeValues(nodeCounter)
                
                nodeValues(nodeCounter) = Array(firstDigit,thirdColumnValue)
                
                nodeCounter = nodeCounter + 1
            Case "Arrow"
                Dim matchedNodeFirstValue As String
                Dim matchedNodeSecondValue As String
                matchedNodeFirstValue = IsInArrayReturnItem(firstDigit,nodeValues)(1)
                matchedNodeSecondValue = IsInArrayReturnItem(secondDigit,nodeValues)(1)
                If matchedNodeFirstValue <> vbNullString And matchedNodeSecondValue <> vbNullString Then
                    valueCell.Offset(,3).Value = matchedNodeFirstValue & Space(1) & thirdColumnValue & Space(1) & matchedNodeSecondValue
                End If
            End Select
        
        End If
    
    Next valueCell
    
CleanExit:
    Exit Sub
 
CleanFail:
    Debug.Print "Something went wrong: " & Err.Description
    Resume CleanExit
    
End Sub

' Credits: https://stackoverflow.com/a/38268261/1521579
Public Function IsInArrayReturnItem(stringToBeFound As Integer,arr As Variant) As Variant
    Dim i
    For i = LBound(arr) To UBound(arr)
        If arr(i)(0) = stringToBeFound Then
            IsInArrayReturnItem = arr(i)
            Exit Function
        End If
    Next i
    IsInArrayReturnItem = Array(vbNullString,vbNullString)
End Function

让我知道它是否有效

您似乎是根据

串联查找

第一个和第二个整数
第二列=“箭头”

如果是这种情况，我建议：

将数据表读取到VBA阵列中以加快处理速度
- 我假设您的数据按显示顺序进行排序，所有Node条目都放在开头。
- 如果不是这种情况，则循环两次-一次找到“节点”，第二次连接“箭”数据。
将诊断信息读入字典以进行事实查询。
如果column2 =“ Arrow”，则连接对第一个和第二个整数的查找
回写数据

注意：按照书面规定，这将覆盖原始表格，从而破坏其中可能存在的所有公式。如果需要，您可以轻松地对其进行修改，以仅覆盖必要的区域。

注意2 请确保在Tools/References上设置引用（在Microsoft Scripting Runtime下），或将Dictionary声明更改为后期绑定。

常规模块

'set reference to Microsoft Scripting Runtime
Option Explicit
Sub Dx()
    Dim WS As Worksheet
    Dim rngData As Range,c As Range,vData As Variant
    Dim dDx As Dictionary
    Dim I As Long,sKey As String,dxKeys As Variant
    
'Get the data range
Set WS = ThisWorkbook.Worksheets("sheet1")
With WS

    'assume table starts in A1 and is three columns wide
    Set rngData = .Range(.Cells(1,1),.Cells(.Rows.Count,1).End(xlUp)).Resize(columnsize:=3)
    
    'read into variant array for faster processing
    vData = rngData
End With

'create dictionsry for dx lookups
Set dDx = New Dictionary
For I = 2 To UBound(vData,1)
    Select Case vData(I,2)
        Case "Node"
            sKey = Split(vData(I,")(0) 'first comma-separated number
            If dDx.Exists(sKey) Then
                MsgBox "duplicate diagnostic key. Please correct the data"
                Exit Sub
            End If
    
            dDx.Add Key:=sKey,Item:=vData(I,3)
            
        Case "Arrow"
            dxKeys = Split(vData(I,")
            vData(I,3) = dDx(dxKeys(0)) & " + " & dDx(dxKeys(1))
    End Select
Next I

'reWrite the table
Application.ScreenUpdating = False
rngData = vData
    
End Sub

如果其他列中的第一个整数或第一个和第三个整数匹配，则VBA代码可连接列中的字符串

如何解决如果其他列中的第一个整数或第一个和第三个整数匹配，则VBA代码可连接列中的字符串

解决方法

代码：

相关推荐