Question

我的数据在A列和B列中有更改请求数据。我需要移动此数据，以便与单个更改请求相关的所有数据都在其自己的行上。

我一直在研究一个VBA宏，它会遍历Sheet1 A列以查找特定的字符串，然后将它们粘贴到Sheet2上的不同列，具体取决于它的String类型。

到目前为止，我已经找到了这个，但我的问题如下：我在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等，但这是对未来的担忧。

Answer 1

我认为除了“datarow”（i）之外，你还想要一个“reportrow”。

  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

Answer 2

此代码需要添加对 Microsoft Scripting Runtime 库（对于词典）的引用。我基于几个假设来建立这个代码：

报告始终直接放在相关的更改编号下。
变更编号都是唯一的
与更改编号关联的报告编号均为唯一。
报告总是有三种描述：
- 工作量
- 要求
- 开发
您没有兴趣保留＆＃34;更改主题＆＃34;每个变更编号下的注释（这已在下面的编辑中进一步说明）

此代码不是直接将信息从一个工作表移动到另一个工作表，而是将数据收集到字典中;然后将该数据提取回最终工作表。这也从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

VBA宏在保持排序的同时查找特定字符串

2 个答案: