vba 根据sheet名称查找数据 急！在线等！

Posted 2023-05-11

根据代码（B列）及时间（C列）在各sheet里查找数据后输出在价格列中（D列）
代码是每个原数据sheet的名字
时间是每个原数据sheet的B列
输出原数据sheet的C列

不知道有没有表达清楚！在线等！

sub test()
rowconut=sheets("Analysis").[b90000].end(xlup).row
for i=3 to rowconut
sheetsname=sheets("Analysis").range("B" & i ).value
datanum=sheets("Analysis").range("C" & i ).value
rownum=sheets(sheetsname).cells.find(datanum).row
sheets("Analysis").range("D" & i ).value=sheets(sheetsname).range("C" & rownum).value
next
end sub

请测试，通过循环Analysis的代码，查找对应的sheet，然后通过日期找到对应的位置,再将价格粘贴到Analysis

参考技术A 如果时间在对应表中都存在的话，还是比较简单的。
for i=3 to [b65536].end(3).row
range("D"& i)=sheets(range("B"& i)).range("B:B").find(range("C"& i)).offset(,1)
next 参考技术B 一共两个工作表慢啊慢找就好了吧。追问

当然不是只有两个工作表 只是作为实例简单贴了两个而已。。。

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

【中文标题】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 我尝试仔细检查我包含的第二个代码，在示例数据上运行它（不更改任何内容）。我附上了我的样本数据的图像，之前/之后。看起来它对我有用。您是否对代码进行了任何更改？