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 

我還附上了Excel文件的主人MediaFire：

Excel files

請你幫忙。

非常感謝:)

Answer 1

所以我擡頭看着資源很多，並試圖遵循什麼@Tim威廉姆斯告訴我，和整個這個頁面（最後一部分）偶然發現：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列標題不匹配，我暫時修正了它，因爲我環顧四周，找不到自動修剪所有空間的方法整個專欄。

所以這是它:)