卡住使用轉置

Question

我試圖從其他工作簿中提取數據到主工作簿。所有這些工作簿都保存在一個文件夾中。我想自動打開其他工作簿而不是手動。我需要提取的數據是非相鄰單元格，我希望從每個源工作簿中提取的數據顯示在主工作簿中的行中（因爲我在第1行中有一個首行，所以從第一個工作簿中提取數據後並粘貼到第2行，從第二個工作簿中提取的數據將在第3行中列出，依此類推）

但是，當我運行宏時，我被困在Transpose中。

下面是我的代碼

Sub LoopThroughDirectory() 
    Dim MyFile As String 
    Dim wkbSource As Workbook 
    Dim wkbTarget As Workbook 
    Dim erow As Single 
    Dim Filepath As String 
    Dim copyRange As Range 
    Dim cel As Range 
    Dim pasteRange As Range 

    Filepath = "C:\xxxxx\" 
    MyFile = Dir(Filepath) 

    Do While Len(MyFile) > 0 
     If MyFile = "Import Info.xlsm" Then GoTo NextFile  
     Set wkbTarget = Workbooks("Import Info.xlsm") 

     Set wkbSource = Workbooks.Open(Filepath & MyFile) 
     Set copyRange = wkbSource.Sheets("sheet1").Range("c3,f6,f9,f12,f15,f19,f21,f27,f30,f33,f37,f41") 
     Set pasteRange = wkbTarget.Sheets("sheet1").Range("a1") 

     For Each cel In copyRange 
      cel.Copy 
      ecolumn = wkbTarget.Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Column 
      wkbTarget.Worksheets("Sheet1").Paste Destination:=wkbTarget.Worksheets("Sheet1").Range(Cells(1, ecolumn).Address) 
      pasteRange.Cells(1, ecolumn).PasteSpecial xlPasteValues 

     Next 
     Application.CutCopyMode = False 

     wkbSource.Close 

    NextFile: 
     MyFile = Dir 

    Loop 

End Sub 

我迄今所做的：

1. 我轉我從源工作簿中提取的數據，但他們並沒有在主簿爲我所期待的顯示。他們都在第1行
2. 我沒有太多的VBA經驗，我覺得我寫的代碼複製非相鄰的單元格和轉移主工作簿使循環變得更加複雜。但我不知道我錯在哪裏或如何解決這個問題。

請幫幫我。非常感謝！

Answer 1

你必須設定目標範圍的循環之外，並抵消它的循環內：

Sub LoopThroughDirectory() 
    Dim Filepath As String, MyFile As String 
    Dim wkbSource As Workbook, wkbTarget As Workbook 
    Dim copyRange As Range, cel As Range, pasteRange As Range 

    Set wkbTarget = Workbooks("Import Info.xlsm") 
    Set pasteRange = wkbTarget.Sheets("sheet1").Range("a2") ' start at row 2 

    Filepath = "C:\xxxxx\" 
    MyFile = Dir(Filepath) 

    While MyFile > "" 
     If MyFile = "Import Info.xlsm" Then GoTo NextFile  

     Set wkbSource = Workbooks.Open(Filepath & MyFile) 
     Set copyRange = wkbSource.Sheets("sheet1").Range("c3,f6,f9,f12,f15,f19,f21,f27,f30,f33,f37,f41") 

     For Each cel In copyRange 

      pasteRange.Value = cel.Value ' "copy" the value 

      Set pasteRange = pasteRange.Offset(, 1) ' move to the next column 

     Next 

     wkbSource.Close 

     Set pasteRange = pasteRange.EntireRow.Resize(1,1) ' move back to the first cell in the row 

     Set pasteRange = pasteRange.Offset(1) ' move to the cell bellow (next row) 

    NextFile: 
     MyFile = Dir 

    Wend  
End Sub