How to merge data from multiple sheets?

Question

Update: sample file sample workbook

Problem: I would like to have something that can automatically

1. Search for the part number and revision. After the cell which contains "PART NUMBER" and "REVISION" is found, I need to get the values of below two cell (offset 1 column).

2. It will continue to look for the summary table

3. Put the summary table to a result sheet

4. Continue searching and repeat the process

There are:

• Possible of multiple parts number on the same sheet or just 1
• Only searching for the Sheet with starting name: "Search"

First Picture shows the structure of the file and the Second Picture shows the result

This will help a lot if it is doable. Please help me.

Update 1: Logic as I think: 1. Write a module to search for all sheets starting with name "SEARCH"

2. Go to each sheet resulted from step 1 - to search .NEXT for PART NUMBER and REVISION to get all part number name and revision (addressing by offset(0,1))

3. Start to search for the summary table ==> It gets to complicated point

Answer 1

Is this what you are trying?

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

SAMPLE FILE

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

Answer 2

Wow, this takes me back to the days when I had to do this nasty stuff a lot!

Anyway, I wrote some code that gets what you want. I may have taken a different approach than you may have thought, but I think it's kind of similar.

Assumptions

PART NUMBER is always in Column B

REVISION is always in Column F

Double check all other references against your original data. I could not access your workbook (due to my work office security), so I made my own book up based on your screenshots).

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