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列标题不匹配，我有点暂时修复它，因为我环顾四周，无法找到自动修剪所有空间的方法整栏。

就是这样:)）

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

1 个答案: