试图从大括号中提取数据但不起作用

Question

我需要同步C列中的花括号{}中的值，并将它们放在F列中的用户ID中，如下所示。

E.g。在电子邮件表上

在新表

上成为了这个

Sub CopyConditional()
Dim wshS As Worksheet
Dim WhichName As String

Set wshS = ActiveWorkbook.Sheets("Emails")
WhichName = "NewSheet"

Const NameCol = "C"
Const FirstRow = 1

Dim LastRow As Long
Dim SrcRow As Long
Dim TrgRow As Long
Dim wshT As Worksheet
Dim cpt As String
Dim user As String
Dim computers() As String
Dim computer As String

On Error Resume Next
Set wshT = Worksheets(WhichName)
If wshT Is Nothing Then
    Set wshT = Worksheets.Add(After:=wshS)
    wshT.Name = WhichName
End If
On Error GoTo 0

If wshT.Cells(1, NameCol).value = "" Then
    TrgRow = 1
Else
    TrgRow = wshT.Cells(wshT.Rows.Count, NameCol).End(xlUp).Row + 1
End If

LastRow = wshS.Cells(wshS.Rows.Count, NameCol).End(xlUp).Row
For SrcRow = FirstRow To LastRow
    cpt = wshS.Range("C" & SrcRow).value
    user = wshS.Range("F" & SrcRow).value

    If InStr(cpt, ":") Then
        cpt = Mid(cpt, InStr(1, cpt, ":") + 1, Len(cpt))
    End If

    If InStr(cpt, ";") Then
        computers = Split(cpt, ";")
        For i = 0 To UBound(computers)
            If computers(i) <> "" Then
                wshT.Range("A" & TrgRow).value = user
                wshT.Range("B" & TrgRow).value = Mid(Left(computers(i), Len(computers(i)) - 1), 2)
                TrgRow = TrgRow + 1
            End If
        Next
    Else
        computer = cpt
        If computer <> "" Then
            wshT.Range("A" & TrgRow).value = user
            wshT.Range("B" & TrgRow).value = Mid(Left(computer, Len(computer) - 1), 2)
            TrgRow = TrgRow + 1
        End If
    End If

Next SrcRow

End Sub

我设法使用上面的代码解决了这个问题，但有3个棘手的问题：

1）总是复制第一个花括号，如何省略这个，{Computer1之类似Computer 1

2）如果连续有两台计算机，那么输出看起来像这样：

当它真的应分成两个不同的行，即

User 1 | Computer 1
User 1 | Computer 2

3）如果最后一个大括号后面有文字，其中有文字，例如{Computer1};{Computer2};Request submitted然后该文本被添加为新行，我不想要这个，我希望它被省略，例如。

应该是：

User 1 | Computer 1
User 1 | Computer 2

如何纠正这些问题？

Answer 1

1）使用Mid函数删除第一个字符：

str = "{Computer1"
str = Mid(str,2)

现在str =＆＃34; Computer1＆＃34;

2）您可以使用Split功能将这些分开并与上面的Mid函数结合使用

str = "{Computer1}{Computer2}"
splt = Split(str,"}")
for a = 0 to Ubound(splt)
     result = Mid(splt(a),2)
next a

3）将条件语句添加到上面的循环

str = "{Computer1}{Computer2}"
splt = Split(str,"}")
for a = 0 to Ubound(splt)
     if Left(splt(a),1) = "{" then result = Mid(splt(a),2)
next a

使用此循环并将每个结果发送到所需的单元格（在for-next循环中），你应该好好去。

Answer 2

我使用自定义解析函数进行此类操作：

Sub CopyConditional()
  ' some detail left out
  Dim iRow&, Usern$, Computer$, Computers$
  For iRow = ' firstrow To lastrow
    Usern = Sheets("Emails").Cells(iRow, "F")
    Computers = Sheets("Emails").Cells(iRow, "C")
    Do
      Computer = zParse(Computers) ' gets one computer
      If Computer = "" Then Exit Do
      ' Store Computer and Usern
    Loop
  Next iRow
End Sub

Function zParse$(Haystack$) ' find all {..}
  Static iPosL& '
  Dim iPosR&
  If iPosL = 0 Then iPosL = 1
  iPosL = InStr(iPosL, Haystack, "{") ' Left
  If iPosL = 0 Then Exit Function ' no more
  iPosR = InStr(iPosL, Haystack, "}") ' Right
  If iPosR = 0 Then MsgBox "No matching }": Stop
  zParse = Mid$(Haystack, iPosL + 1, iPosR - iPosL - 1)
  iPosL = iPosR
End Function

Answer 3

试试这个：

Sub Collapse()
    Dim uRng As Range, cel As Range
    Dim comps As Variant, comp As Variant, r As Variant, v As Variant
    Dim d As Dictionary '~~> Early bind, for Late bind use commented line
    'Dim d As Object
    Dim a As String

    With Sheet1 '~~> Sheet that contains your data
        Set uRng = .Range("F1", .Range("F" & .Rows.Count).End(xlUp))
    End With

    Set d = CreateObject("Scripting.Dictionary")
    With d
        For Each cel In uRng
            a = Replace(cel.Offset(0, -3), "{", "}")
            comps = Split(a, "}")
            Debug.Print UBound(comps)
            For Each comp In comps
                If InStr(comp, "Computer") <> 0 _
                And Len(Trim(comp)) <= 10 Then '~~> I assumed max Comp# is 99
                    If Not .Exists(cel) Then
                        .Add cel, comp
                    Else
                        If IsArray(.Item(cel)) Then
                            r = .Item(cel)
                            ReDim Preserve r(UBound(r) + 1)
                            r(UBound(r)) = comp
                            .Item(cel) = r
                        Else
                            r = Array(.Item(cel), comp)
                            .Item(cel) = r
                        End If
                    End If
                End If
            Next
        Next
    End With

    For Each v In d.Keys
        With Sheet2 '~~> sheet you want to write your data to
            If IsArray(d.Item(v)) Then
                .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) _
                    .Resize(UBound(d.Item(v)) + 1) = v
                .Range("B" & .Rows.Count).End(xlUp).Offset(1, 0) _
                    .Resize(UBound(d.Item(v)) + 1) = Application.Transpose(d.Item(v))
            Else
                .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) = v
                .Range("B" & .Rows.Count).End(xlUp).Offset(1, 0) = d.Item(v)
            End If
        End With
    Next
    Set d = Nothing

End Sub

上面的代码使用替换和拆分功能将字符串传递给数组。

a = Replace(cel.Offset(0, -3), "{", "}") '~~> standardize delimiter
comps = Split(a, "}") '~~> split using standard delimiter

然后使用User作为键，将计算机作为项目，将信息传递给字典对象 我们使用 Instr和Len函数

过滤传递给字典的项目

If InStr(comp, "Computer") <> 0 _
And Len(Trim(comp)) <= 10 Then

正如我所评论的那样，我认为你的最大电脑号码是99 否则将10更改为您需要检查的长度 最后，我们将字典信息返回到目标工作表 注意：如果您更喜欢早期绑定，则需要添加对Microsoft Scripting Runtime的引用

结果：我尝试了一个小样本数据，模仿了我在你SS中的看法。

假设您在Sheet1中有这些数据：

将在Sheet2中输出数据如下：