合併多個Excel張入彙總表

Question

我不知道是否有人也許能幫助我請。

我使用下面的代碼，以允許用戶從多個Excel工作簿數據拷貝和合併成一個彙總表。

Sub Merge() 
     Dim DestWB As Workbook, WB As Workbook, WS As Worksheet, SourceSheet As String 

     Set DestWB = ActiveWorkbook 
     SourceSheet = "Input" 
     startrow = 7 
     FileNames = Application.GetOpenFilename(_ 
     filefilter:="Excel Files (*.xls*),*.xls*", _ 
     Title:="Select the workbooks to merge.", MultiSelect:=True) 
     If IsArray(FileNames) = False Then 
      If FileNames = False Then 
       Exit Sub 
      End If 
     End If 
     For n = LBound(FileNames) To UBound(FileNames) 
      Set WB = Workbooks.Open(Filename:=FileNames(n), ReadOnly:=True) 
      For Each WS In WB.Worksheets 
       If WS.Name = SourceSheet Then 
        With WS 
         If .UsedRange.Cells.Count > 1 Then 
          dr = DestWB.Worksheets("Input").Range("C" & Rows.Count).End(xlUp).Row + 1 
          lastrow = .Range("C" & Rows.Count).End(xlUp).Row 
          For j = lastrow To startrow Step -1 
           If Range("E" & j) <> "Requirements Manager" And Range("E" & j) <> "R & D Lead" And Range("E" & j) <> "Technical" And Range("E" & j) <> "Analyst" Then Rows(j).Delete 
          Next 
          lastrow = .Range("C" & Rows.Count).End(xlUp).Row 
          If lastrow >= startrow Then 
           .Range("A" & startrow & ":AQ" & lastrow).Copy 
           DestWB.Worksheets("Input").Cells(dr, "A").PasteSpecial xlValues 
          End If 
         End If 
        End With 
        Exit For 
       End If 
      Next WS 
      WB.Close savechanges:=False 
     Next n 
    End Sub 

代碼工作正常，但我堅持與相關的信息，這是這行代碼複製一個問題：

.Range("A" & startrow & ":AQ" & lastrow).Copy 

我需要改變這種做法，它需要考慮到兩個範圍。這些都是列「B：AD」和「自動對焦：AQ」，但我不知道如何做到這一點。

我只是想知道wehether有人也可能採取看看這個，請，並提供如何，我可以去解決這一些指導。

許多的感謝和親切的問候

Answer 1

在下面所有的我認爲你確實不希望列A複製到目標工作簿和工作表。

你可以使用Union複製粘貼一次過（當時在兩者之間也不會反映任何列粘貼時：

     If lastrow >= startrow Then 
          Union(.Range("B" & startrow & ":AD" & lastrow), .Range("AF" & startrow & ":AQ" & lastrow).Copy 
          DestWB.Worksheets("Input").Cells(dr, "B").PasteSpecial xlValues 
         End If 

如果你希望它與它之間的房貼，以及那麼你可以簡單地r3epeat複製和粘貼線路：

     If lastrow >= startrow Then 
          .Range("B" & startrow & ":AD" & lastrow).Copy 
          DestWB.Worksheets("Input").Cells(dr, "B").PasteSpecial xlValues 
          .Range("AF" & startrow & ":AQ" & lastrow).Copy 
          DestWB.Worksheets("Input").Cells(dr, "AF").PasteSpecial xlValues 
         End If