vba 如何合并多个工作表中的数据？
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/10806480/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
How to merge data from multiple sheets?
提问by NCC
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).
1. 搜索部件号和版本。找到包含“PART NUMBER”和“REVISION”的单元格后，我需要获取以下两个单元格（偏移1列）的值。
2. It will continue to look for the summary table
2. 它会继续寻找汇总表
3. Put the summary table to a result sheet
3. 将汇总表放入结果表
4. Continue searching and repeat the process
4. 继续搜索并重复该过程
There are:
有：
- Possible of multiple parts number on the same sheet or just 1
- Only searching for the Sheet with starting name: "Search"
- 同一张纸上可能有多个零件号或只有 1 个
- 仅搜索具有起始名称的工作表：“搜索”
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"
更新 1：我认为的逻辑： 1. 编写一个模块来搜索以名称“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
转到第 1 步产生的每个工作表 - 在 .NEXT 中搜索 PART NUMBER 和 REVISION 以获取所有零件号名称和修订版（按偏移量（0,1）寻址）
开始搜索汇总表 ==> 到了复杂点
回答by Scott Holtzman
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
零件编号始终在 B 列中
REVISION is always in Column F
REVISION 始终在 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
回答by Siddharth Rout
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
i.minus.com/1338702873/20yZJWFxgv9Egtd4klNOBg/dtst1Y4ckv86f/Sample.xlsm
