Question

更新：示例文件sample workbook

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

的东西

1 即可。搜索部件号和修订版。在找到包含“PART NUMBER”和“REVISION”的单元格之后，我需要得到低于两个单元格的值（偏移1列）。

2 即可。它将继续寻找摘要表

第3 即可。将摘要表放在结果表

中

4 即可。继续搜索并重复该过程

有：

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

enter image description here

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

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

更新1：我认为逻辑： 1.编写模块以搜索以名称“SEARCH”

开头的所有工作表

转到步骤1产生的每张工作表 - 搜索.NEXT获取部件编号和修订以获取所有部件编号名称和修订版（通过偏移（0,1）寻址）
开始搜索摘要表==＆gt;它变得复杂了

Answer 1

哇，这让我回到了我不得不做这件令人讨厌的事情的日子！

无论如何，我写了一些代码来获得你想要的东西。我可能采取了与你想象的不同的方法，但我认为它有点类似。

假设

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

Answer 2

这是你在尝试的吗？

enter image description here

<强> CODE

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

如何合并多张表中的数据？

2 个答案: