0

更新：示例文件示例工作簿

问题：我想要一些可以自动

1 . 搜索部件号和版本。找到包含“PART NUMBER”和“REVISION”的单元格后，我需要获取以下两个单元格的值（偏移量 1 列）。

2 . 它将继续寻找汇总表

3 . 将汇总表放入结果表

4 . 继续搜索并重复该过程

有：

  • 同一张纸上可能有多个零件号或只有 1 个
  • 仅搜索具有起始名称的工作表：“搜索”

在此处输入图像描述

在此处输入图像描述

第一张图显示文件的结构，第二张图显示结果

如果可行，这将有很大帮助。请帮我。

更新1：我认为的逻辑：1.编写一个模块来搜索以名称“SEARCH”开头的所有工作表

  1. 转到步骤 1 产生的每张表 - 在 .NEXT 中搜索 PART NUMBER 和 REVISION 以获取所有部件号名称和修订版（按偏移量 (0,1) 寻址）

  2. 开始搜索汇总表 ==> 复杂点

4

2 回答 2

2

哇，这让我回到了我不得不经常做这些讨厌的事情的日子！

无论如何，我写了一些代码，可以得到你想要的。我可能采取了与您想象的不同的方法，但我认为它有点相似。

假设

PART NUMBER 总是在 B 列中

REVISION 总是在 F 列

根据您的原始数据仔细检查所有其他参考。我无法访问您的工作簿（由于我的工作办公室安全），所以我根据您的屏幕截图制作了自己的工作簿）。

Option Explicit

Sub wowzer()

Dim wks As Worksheet, wksResult As Worksheet

'set up results sheet
Set wksResult = Worksheets.Add(After:=Worksheets(Worksheets.Count))
With wksResult
    .Name = "Results"
    .Range("A1:F1") = Array("Part", "Rev", "Name", "Category", "TotalA", "TotalB")
End With

'loop through sheets to get data over
For Each wks In Worksheets

    If Left(wks.Name, 6) = "Search" Then ' does sheet start with search?

        With wks

            Dim rngFindPart As Range, rngFindName As Range

            Set rngFindPart = .Columns(2).Find("PART NUMBER", lookat:=xlWhole, After:=.Range("B" & .Rows.Count))
            Set rngFindName = .Columns(2).Find("NAME", lookat:=xlWhole, After:=.Range("B" & .Rows.Count))

            Dim strFrstAdd As String
            strFrstAdd = rngFindPart.Address 'used as a check for when we loop back and find first "PART NUMBER" again

            If Not rngFindPart Is Nothing Or Not rngFindName Is Nothing Then
            'not going to do anything if no PART NUMBER or NAME found

                Do

                    Dim rngMove As Range

                    'copy table and place it in result sheet
                    Set rngMove = .Range(rngFindName.Offset(1).Address, rngFindName.End(xlToRight).End(xlDown))
                    rngMove.Copy wksResult.Range("C" & wksResult.Rows.Count).End(xlUp).Offset(1)

                    'place part and revision, aligned with table (will de-duplicate later)
                    With wksResult
                        .Range(.Range("A" & .Rows.Count).End(xlUp).Offset(1), .Range("A" & .Rows.Count).End(xlUp).Offset(2)) = rngFindPart.Offset(1)
                        .Range(.Range("B" & .Rows.Count).End(xlUp).Offset(1), .Range("B" & .Rows.Count).End(xlUp).Offset(2)) = rngFindPart.Offset(1, 4)
                    End With

                    'find next instance of "PART NUMBER" and "NAME"
                    Set rngFindPart = .Columns(2).Find("PART NUMBER", lookat:=xlWhole, After:=rngFindPart)
                    Set rngFindName = .Columns(2).Find("NAME", lookat:=xlWhole, After:=rngFindPart)

                'done when no part number exists or it's the first instance we found
                Loop Until rngFindPart Is Nothing Or rngFindPart.Address = strFrstAdd

            End If

        End With

    End If

Next

'de-duplicate results sheet
With wksResult

    'if sheet is empty do nothing
    If .Cells(2, 1) <> vbNullString Then

        .UsedRange.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6), Header:=xlYes

    End If

End With


End Sub
于 2012-06-01T17:40:03.543 回答
1

这是你正在尝试的吗？

在此处输入图像描述

代码

Option Explicit

Const SearchString As String = "PART NUMBER"

Dim wsO As Worksheet, WsI1 As Worksheet, WsI2 As Worksheet
Dim lRow As Long

Sub Sample()
    Set wsO = Sheets("Result")
    Set WsI1 = Sheets("SEARCH PAGE1")
    Set WsI2 = Sheets("SEARCH PAGE2")

    lRow = 2

    PopulateFrom WsI1
    PopulateFrom WsI2
End Sub

Sub PopulateFrom(ws As Worksheet)
    Dim aCell As Range, bCell As Range, cCell As Range, nmRng As Range, cl As Range
    Dim i As Long
    Dim ExitLoop As Boolean

    With ws
        Set aCell = .Cells.Find(What:=SearchString, LookIn:=xlValues, _
                    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=False, SearchFormat:=False)

        If Not aCell Is Nothing Then
            Set bCell = aCell
            wsO.Range("A" & lRow).Value = aCell.Offset(1).Value
            wsO.Range("B" & lRow).Value = aCell.Offset(1, 3).Value
            i = 1
            Do
                If aCell.Offset(i) = "NAME" Then
                    Set nmRng = .Range(aCell.Offset(i), aCell.Offset(i).End(xlDown))
                     For Each cl In nmRng
                        If cl.Value <> "NAME" Then
                            If wsO.Range("A" & lRow).Value = "" Then
                                wsO.Range("A" & lRow).Value = wsO.Range("A" & lRow - 1).Value
                                wsO.Range("B" & lRow).Value = wsO.Range("B" & lRow - 1).Value
                            End If

                            wsO.Range("C" & lRow).Value = cl.Value
                            wsO.Range("D" & lRow).Value = cl.Offset(, 1).Value
                            wsO.Range("E" & lRow).Value = cl.Offset(, 2).Value
                            wsO.Range("F" & lRow).Value = cl.Offset(, 3).Value
                            lRow = lRow + 1
                        End If
                     Next
                    Exit Do
                End If
                i = i + 1
            Loop

            Do While ExitLoop = False
                Set aCell = .Cells.FindNext(After:=aCell)

                If Not aCell Is Nothing Then
                    If aCell.Address = bCell.Address Then Exit Do
                    wsO.Range("A" & lRow).Value = aCell.Offset(1).Value
                    wsO.Range("B" & lRow).Value = aCell.Offset(1, 3).Value
                    i = 1
                    Do
                        If aCell.Offset(i) = "NAME" Then
                            Set nmRng = .Range(aCell.Offset(i), aCell.Offset(i).End(xlDown))
                             For Each cl In nmRng
                                If cl.Value <> "NAME" Then
                                    If wsO.Range("A" & lRow).Value = "" Then
                                        wsO.Range("A" & lRow).Value = wsO.Range("A" & lRow - 1).Value
                                        wsO.Range("B" & lRow).Value = wsO.Range("B" & lRow - 1).Value
                                    End If
                                    wsO.Range("C" & lRow).Value = cl.Value
                                    wsO.Range("D" & lRow).Value = cl.Offset(, 1).Value
                                    wsO.Range("E" & lRow).Value = cl.Offset(, 2).Value
                                    wsO.Range("F" & lRow).Value = cl.Offset(, 3).Value
                                    lRow = lRow + 1
                                End If
                             Next
                            Exit Do
                        End If
                        i = i + 1
                    Loop
                Else
                    ExitLoop = True
                End If
            Loop
        End If
    End With
End Sub

样本文件

i.minus.com/1338702873/20yZJWFxgv9Egtd4klNOBg/dtst1Y4ckv86f/Sample.xlsm

于 2012-06-02T05:49:05.510 回答