How to merge data from multiple sheets? - excel

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"
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))
Start to search for the summary table ==> It gets to complicated point

Answer 1

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

Answer 2

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