Excel-根据特定文本将相邻数据值复制到另一个工作表，直到工作表结束

所以我有两个excel文档

从中获取数据的一个（RESULT.xlsm）

另一个要插入数据的文件（Summary.xls）

我想要的是高亮名称旁边的相邻单元格值，以便插入到相应列下的Summary.xls中。所以我试着录制一个宏，但是只插入了第一条记录

因为我只允许两个链接，所以我将其全部放在一张图片中：

注意：RESULT.xlsm中有多条记录，屏幕截图仅显示一条

我希望获得有关如何从所有记录集中提取数据并插入Summary.xlsx的帮助

以下是录制的宏代码：

Sub Summ()

Workbooks.Open Filename:="Summary.xlsx"
Windows.Arrange ArrangeStyle:=xlVertical
Windows("RESULT.xlsm").Activate
Cells.Find(What:="Air System Name", After:=ActiveCell, LookIn:=xlFormulas _
    , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False).Activate
Range("B10").Select
Selection.Copy
Windows("Summary.xlsx").Activate
Range("A5").Select
ActiveSheet.Paste
Windows("RESULT.xlsm").Activate
Cells.Find(What:="Floor Area", After:=ActiveCell, LookIn:=xlFormulas, _
    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False).Activate
Range("B14").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Summary.xlsx").Activate
Range("B5").Select
ActiveSheet.Paste
Windows("RESULT.xlsm").Activate
Cells.Find(What:="Total coil load", After:=ActiveCell, LookIn:=xlFormulas _
    , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False).Activate
Range("B27").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Summary.xlsx").Activate
Range("C5").Select
ActiveSheet.Paste
Windows("RESULT.xlsm").Activate
Cells.Find(What:="Sensible coil load", After:=ActiveCell, LookIn:= _
    xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
    xlNext, MatchCase:=False, SearchFormat:=False).Activate
Range("B28").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Summary.xlsx").Activate
Range("D5").Select
ActiveSheet.Paste
Windows("RESULT.xlsm").Activate
Cells.Find(What:="Max block L/s", After:=ActiveCell, LookIn:=xlFormulas, _
    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False).Activate
Range("B30").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Summary.xlsx").Activate
Range("E5").Select
ActiveSheet.Paste
Range("A6").Select

End Sub

我还附上了mediafire的excel文件：

请帮忙

---

非常感谢：）

因此，我查阅了大量资源，试图按照@Tim Williams告诉我的内容进行操作，无意中发现了此页面（最后一部分）：

他们有一个几乎接近我的问题的解决方案，所以我做了一些修改，我完成了：D

注：这是在同一份文件中，不同的表格

它的代码是：

Dim LR As Long, NR As Long, Rw As Long
Dim wsData As Worksheet, wsOUT As Worksheet
Dim HdrCol As Range, Hdr As String, strRESET As String

Set wsData = Sheets("Sheet1")   'source data
Set wsOUT = Sheets("Sheet2")    'output sheet
strRESET = "    Air System Name "    'this value will cause the record row to increment

LR = wsData.Range("A" & Rows.Count).End(xlUp).Row
'end of incoming data
Set HdrCol = wsOUT.Range("1:1").Find(strRESET, _
        LookIn:=xlValues, LookAt:=xlWhole)      'find the reset category column
If HdrCol Is Nothing Then
MsgBox "The key string '" & strRESET & _
    "' could not be found on the output sheet."
Exit Sub
End If

NR = wsOUT.Cells(Rows.Count, HdrCol.Column) _
        .End(xlUp).Row      'current output end of data

Set HdrCol = Nothing

On Error Resume Next
For Rw = 1 To LR
Hdr = wsData.Range("A" & Rw).Value



If (Hdr = "    Air System Name ") Then
NR = NR + 1
End If

If Hdr <> "" Then

    Set HdrCol = wsOUT.Range("1:1").Find(Hdr, _
            LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)

    If Not HdrCol Is Nothing Then
        wsOUT.Cells(NR, HdrCol.Column).Value _
                = wsData.Range("B" & Rw).Value

        Set HdrCol = Nothing
    End If
End If
Next Rw

Dim LR为长、NR为长、Rw为长
将wsData设置为工作表，将wsOUT设置为工作表
Dim HdrCol作为范围，Hdr作为字符串，STRESET作为字符串
设置wsData=Sheets（“Sheet1”）源数据
设置wsOUT=图纸（“图纸2”）“输出图纸
strRESET=“Air System Name”'此值将导致记录行递增
LR=wsData.Range（“A”&Rows.Count）.End（xlUp）.Row
'传入数据的结束
设置HdrCol=wsOUT.Range（“1:1”）.Find（strRESET_
LookIn:=xlValues，LookAt:=xlWhole）“查找重置类别列
如果HdrCol不算什么，那么
MsgBox“密钥字符串”&strRESET&_
在输出工作表上找不到“”
出口接头
如果结束
NR=wsOUT.Cells（Rows.Count，HdrCol.Column）_
.End（xlUp）.Row'数据的当前输出端
设置HdrCol=Nothing
出错时继续下一步
对于Rw=1至LR
Hdr=wsData.Range（“A”&Rw）.Value
如果（Hdr=“空气系统名称”），则
NR=NR+1
如果结束
如果Hdr为“”，则
设置HdrCol=wsOUT.Range（“1:1”）.Find（Hdr_
LookIn:=xlValues，LookAt:=xlother，MatchCase:=False）
如果HdrCol不是空的，那么
wsOUT.Cells（NR，HdrCol.Column）.Value_
=wsData.Range（“B”&Rw）.Value
设置HdrCol=Nothing
如果结束
如果结束
下一个Rw

唯一的小问题是空间。在我的excel文档中，我的报表有尾随空格和前导空格，这与我的sheet2列标题不匹配，我暂时修复了它，因为我环顾四周，找不到自动修剪整列所有空格的方法

---

就是这样：）

如果源文件中有多条记录，那么更好的方法是在RESULT.xlsm中的ColumnA中循环查找搜索文本。当您点击一条新记录时（例如，每次“空气系统名称”出现），然后在汇总表中开始一个新行。