VBA 宏在保持顺序的同时查找特定字符串
Posted
技术标签:
【中文标题】VBA 宏在保持顺序的同时查找特定字符串【英文标题】：VBA macro to find specific strings while maintaining the ordering 【发布时间】：2018-05-23 15:02:09 【问题描述】：我的数据在 A 列和 B 列中有更改请求数据。我需要移动这些数据，以便与单个更改请求相关的所有数据都位于单独的行中。
我一直在研究一个 VBA 宏，它会遍历 Sheet1 A 列以查找特定字符串，然后根据字符串的类型将它们粘贴到 Sheet2 上的不同列。
到目前为止，我已经解决了这个问题，但我的问题如下：我在 A 列中有数据，其中包含更改编号和报告编号。更改编号下可以有多个报告。当我遍历这个时，我设法得到：
将数字更改为 A 列 将数字报告到 B 列但是，由于有时在一个更改编号下有多个报告，我很难将这些报告保持在正确的顺序。更改编号需要根据先前更改编号下的报告数量跳过行。如何根据单元格下的报告数量使更改编号跳过单元格？我尝试在当前循环中使用另一个循环来检查更改有多少报告，但似乎无法使其工作。
我现在的代码是这样的：
Sub search_and_extract()
Dim datasheet As Worksheet
Dim reportsheet As Worksheet
Dim SearchString As String
Dim i As Integer
Set datasheet = Sheet1
Set reportsheet = Sheet2
reportsheet.Range("A1:H200").ClearContents
datasheet.Select
finalrow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To finalrow
SearchString = datasheet.Range("A" & i)
If InStr(1, SearchString, "Change Number") Then
Cells(i, 1).Copy
reportsheet.Select
Range("A200").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
datasheet.Select
ElseIf InStr(1, SearchString, "Report-") Then
Cells(i, 1).Copy
reportsheet.Select
Range("B200").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
datasheet.Select
End If
Next i
reportsheet.Select
End Sub
pic of the formatting of my excel if that helps
我还将尝试从 Sheet1 列 B 到 Sheet2 列 D、E、F 等获取数据，但这是对未来的担忧。
【问题讨论】：
你关心“更改主题”注释吗？ 是的，但我认为这不是超级相关，因为这些在同一意义上没有问题。 【参考方案1】：我认为除了“数据行”（i）之外，您还需要一个“报告行”。
reportrow = 2
For i = 1 To finalrow
SearchString = datasheet.Range("A" & i)
If InStr(1, SearchString, "Change Number") Then
Cells(i, 1).Copy
reportsheet.Select
Cells(reportrow, 1).PasteSpecial xlPasteFormulasAndNumberFormats
reportrow = reportrow + 1
datasheet.Select
ElseIf InStr(1, SearchString, "Report-") Then
Cells(i, 1).Copy
reportsheet.Select
Cells(reportrow, 2).PasteSpecial xlPasteFormulasAndNumberFormats
reportrow = reportrow + 1
datasheet.Select
End If
Next i
【讨论】：
这与我试图让我的工作完全一样。谢谢你。现在我需要考虑逻辑以更好地理解它。【参考方案2】：此代码需要添加对 Microsoft Scripting Runtime 库（用于字典）的引用。我将这段代码建立在几个假设之上：
报告始终直接放在相关的更改编号下方。
变更编号都是唯一的
与更改编号关联的报告编号都是唯一的。
报告总是有三种描述：
工作量 要求 发展您没有兴趣直接在每个更改编号下保留“更改主题”注释（这已在下面的编辑中进一步解决）
此代码不是直接将信息从一张纸移动到另一张纸，而是将数据收集到字典中；然后将该数据提取回最终工作表。这也将数据从 Sheet1 列 B 获取到 Sheet2 列 D、E、F
Sub search_and_extract()
Dim datasheet As Worksheet
Dim reportsheet As Worksheet
Dim SearchString As String
Dim i As Integer
Dim j As Integer
Set datasheet = Sheet1
Set reportsheet = Sheet2
Dim chNum As String
Dim rptNum As String
Dim ChangeNumbers As New Dictionary
Dim dictKey1 As Variant
Dim dictKey2 As Variant
reportsheet.Range("A1:H200").ClearContents
finalrow = datasheet.Cells(datasheet.Rows.Count, 1).End(xlUp).Row
For i = 1 To finalrow
SearchString = datasheet.Range("A" & i)
If InStr(1, SearchString, "Change Number") Then
chNum = datasheet.Cells(i, 1)
ChangeNumbers.Add chNum, New Dictionary 'For report numbers
ElseIf InStr(1, SearchString, "Report-") Then
rptNum = datasheet.Cells(i, 1)
ChangeNumbers.Item(chNum).Add rptNum, New Dictionary 'For details
For j = 0 To 2
ChangeNumbers.Item(chNum).Item(rptNum).Add j, datasheet.Cells(i, 1).Offset(j, 1) ' the details
Next j
End If
Next i
i = 1
For Each dictKey1 In ChangeNumbers.Keys
reportsheet.Cells(i, 1) = dictKey1
If ChangeNumbers.Item(dictKey1).Count > 0 Then
For Each dictKey2 In ChangeNumbers.Item(dictKey1).Keys
reportsheet.Cells(i, 2) = dictKey2
For j = 0 To 2
reportsheet.Cells(i, 4 + j) = ChangeNumbers.Item(dictKey1).Item(dictKey2).Item(j)
Next j
i = i + 1 'moves to new row for new report (or next change number
Next dictKey2
Else
i = i + 1 'no reports, so moves down to prevent overwriting change number
End If
Next dictKey1
End Sub
编辑：
如果需要，包括更改主题的示例。这假设（除上述之外）：
变更主题始终在相关报告之前 不会有任何报告而不更改主题 更改主题将进入 C 列。（例如，可以通过将reportsheet.Cells(i, 3) 更改为 reportsheet.Cells(i, 7) 将其编辑到 G 列）
细节循环部分也进行了一些更改，以适应不断变化的细节数量。此代码的结构使得每个详细信息类型将始终放在同一列中（即需求列、开发列等）
详细循环部分的主要更改来自以下内容：
For j = 0 To 2
ChangeNumbers.Item(chNum).Item(chSub).Item(rptNum).Add j, datasheet.Cells(i, 1).Offset(j, 1) ' the details
Next j
对此（仅包括两种示例类型的详细信息。另请注意，目前，目标列号是硬编码的——最好为所需的列号制作常量，以使代码更具可读性——能够且更易于维护。）：
j = 0
Do While IsEmpty(datasheet.Cells(i + j, 1)) Or datasheet.Cells(i + j, 1) = rptNum
If InStr(1, datasheet.Cells(i + j, 2), "Specified") Then
' The 4 after ".Add" is the column number for this detail in sheet2
ChangeNumbers.Item(chNum).Item(chSub).Item(rptNum).Add 4, datasheet.Cells(i + j, 2) ' the details
ElseIf InStr(1, datasheet.Cells(i + j, 2), "Total Workload") Then
' The 5 after ".Add" is the column number for this detail in sheet2
ChangeNumbers.Item(chNum).Item(chSub).Item(rptNum).Add 5, datasheet.Cells(i + j, 2) ' the details
End If
j = j + 1
Loop
由此而来：
For j = 0 To 2
reportsheet.Cells(i, 4 + j) = ChangeNumbers.Item(dictKey1).Item(dictKey2).Item(dictKey3).Item(j)
Next j
对此（请注意所需的附加变量）：
Dim dictKey4
For each dictKey4 In ChangeNumbers.Item(dictKey1).Item(dictKey2).Item(dictKey3).Keys
reportsheet.Cells(i, dictKey4) = ChangeNumbers.Item(dictKey1).Item(dictKey2).Item(dictKey3).Item(dictKey4)
Next dictKey4
Sub search_and_extract()
Dim datasheet As Worksheet
Dim reportsheet As Worksheet
Dim SearchString As String
Dim i As Integer
Dim j As Integer
Set datasheet = Sheet1
Set reportsheet = Sheet2
Dim chNum As String
Dim chSub as String
Dim rptNum As String
Dim ChangeNumbers As New Dictionary
Dim dictKey1 As Variant
Dim dictKey2 As Variant
Dim dictKey3 As Variant
Dim dictKey4 As Variant
reportsheet.Range("A1:H200").ClearContents
finalrow = datasheet.Cells(datasheet.Rows.Count, 1).End(xlUp).Row
For i = 1 To finalrow
SearchString = datasheet.Range("A" & i)
If InStr(1, SearchString, "Change Number") Then
chNum = datasheet.Cells(i, 1)
ChangeNumbers.Add chNum, New Dictionary 'For report numbers
ElseIf InStr(1, SearchString, "Change Subject") Then
chSub = datasheet.Cells(i, 1)
ChangeNumbers.Item(chNum).Add chSub, New Dictionary 'For report numbers
ElseIf InStr(1, SearchString, "Report-") Then
rptNum = datasheet.Cells(i, 1)
ChangeNumbers.Item(chNum).Item(chSub).Add rptNum, New Dictionary 'For details
j = 0
'Verifies that the details belong to the current report
'String checks are included after locating a report to maintain a connection between the report and its details
Do While IsEmpty(datasheet.Cells(i + j, 1)) Or datasheet.Cells(i + j, 1) = rptNum
If InStr(1, datasheet.Cells(i + j, 2), "Specified") Then
' The 4 after ".Add" is the column number for this detail in sheet2
ChangeNumbers.Item(chNum).Item(chSub).Item(rptNum).Add 4, datasheet.Cells(i + j, 2) ' the details
ElseIf InStr(1, datasheet.Cells(i + j, 2), "Total Workload") Then
' The 5 after ".Add" is the column number for this detail in sheet2
ChangeNumbers.Item(chNum).Item(chSub).Item(rptNum).Add 5, datasheet.Cells(i + j, 2) ' the details
End If
j = j + 1
Loop
End If
Next i
i = 1
For Each dictKey1 In ChangeNumbers.Keys
reportsheet.Cells(i, 1) = dictKey1 'Change Number
If ChangeNumbers.Item(dictKey1).Count > 0 Then
For Each dictKey2 In ChangeNumbers.Item(dictKey1).Keys
reportsheet.Cells(i, 3) = dictKey2 'Change Subject; assuming in column C on same row as Change Number
If ChangeNumbers.Item(dictKey1).Item(dictKey2).Count > 0 Then
For Each dictKey3 In ChangeNumbers.Item(dictKey1).Item(dictKey2).Keys 'Report Number
reportsheet.Cells(i, 2) = dictKey3
'reportsheet.Cells(i, 3) = dictKey2 'Uncomment if you want change subject in every row w/ matching report
For each dictKey4 In ChangeNumbers.Item(dictKey1).Item(dictKey2).Item(dictKey3).Keys
reportsheet.Cells(i, dictKey4) = ChangeNumbers.Item(dictKey1).Item(dictKey2).Item(dictKey3).Item(dictKey4)
Next dictKey4
i = i + 1 'moves to new row for new report (or next change number
Next dictKey3
Else
i = i + 1 'no reports, so moves down to prevent overwriting change number
End If
Next dictKey2
Else
i = i + 1 'no change subject, so moves down to prevent overwriting change number
End If
Next dictKey1
End Sub
【讨论】：
。 . . . . . . . 嗯，这比复制粘贴方法效果更好，因为它运行得更快且性能要求更低。这次真是万分感谢。我现在需要尝试理解代码:) 有趣的是，仅当更改下有多个报告时，它才会提取更改主题注释。等我想通了就会回来。 @user2859557 以下链接提供了一些基本字典属性/方法的答案，并附有一些示例。 ***.com/a/32487945/9259306 @user2859557 我尝试仔细检查我包含的第二个代码，在示例数据上运行它（不更改任何内容）。我附上了我的样本数据的图像，之前/之后。看起来它对我有用。您是否对代码进行了任何更改？以上是关于VBA 宏在保持顺序的同时查找特定字符串的主要内容，如果未能解决你的问题，请参考以下文章