Excel - 根据某些文本将相邻数据值复制到另一个工作表，直到工作表末尾

Question

所以我有两个excel文件。

一个从 (RESULT.xlsm) 中获取数据。

另一个将数据插入(Summary.xls)。

我想要的是突出显示名称旁边的相邻单元格值插入到相应列下的 Summary.xls 中。所以我尝试录制一个宏，但发生的只是第一条记录被插入。

由于我只允许使用两个链接，所以我将它们全部放在一张图片中:
http://i50.tinypic.com/9veihl.png

注意: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 文件:

Excel files

请帮忙。

非常感谢:)

Answer 1

所以我查看了很多资源并尝试按照@Tim Williams 告诉我的内容，偶然发现了这个页面(最后一部分):https://sites.google.com/a/madrocketscientist.com/jerrybeaucaires-excelassistant/text-functions/column-sets-to-rows

他们的解决方案几乎接近我的问题，所以我做了一些修改，我完成了: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

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

就是这样了:)