试图从大括号中提取数据，但不工作

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

例如在电子邮件表上

成为新的表格

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

尝试这个：

 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 

上面的代码使用replace和分割函数将您的string传递给数组。

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

然后信息被传递到字典对象使用用户作为关键和计算机作为项目。
我们使用Instr和Len Function过滤传递给字典的项目

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

正如我所说的，我认为你的最大电脑数是99。
否则更改10到任何你需要检查的长度。
最后，我们将字典信息返回到目标工作表。
注意：如果您喜欢早期绑定，则需要添加对Microsoft脚本运行时的引用

结果：我在一个小样本数据上试了一下，如何在你的SS里看到它。

所以假设你在Sheet1中有这个数据：

将在Sheet2中输出数据，如下所示：

Answer 2

我使用这种types的操作自定义分析函数：

 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

1）使用Midfunction删除第一个字符：

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

现在str =“Computer1”

2）您可以使用拆分function将其分离出来并与上面的Midfunction结合使用

 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循环），你应该很好去。