合併工作表並在Excel中添加列

Question

我有一個包含多個標籤的工作表，用於標識不同的數據源。我需要將所有工作表合併到一個工作表中，並添加一個包含工作表名稱的列作爲新組合工作表的一部分。

我發現下面的代碼，如果我剪切/粘貼到我的工作表中它就像一個魅力，但我有幾個這些工作簿的，我必須能夠每月重建這一過程。

我的研究表明，我應該創造一個COM加載項或可調用宏這一點，但每次我試圖做的過程中失敗。如果somone能指出我在Excel中執行此操作的步驟（2013），並告訴我我的代碼是否可行，我將非常感激。
在此先感謝。

Sub Combine() 
    Dim J As Integer, wsNew As Worksheet 
    Dim rngCopy As Range, rngPaste As Range 
    Dim Location As String 

    On Error Resume Next 
    Set wsNew = Sheets("Combined") 
    On Error GoTo 0 
     'if sheet does not already exist, create it 
     If wsNew Is Nothing Then 
     Set wsNew = Worksheets.Add(before:=Sheets(1)) ' add a sheet in first place 
     wsNew.Name = "Combined" 
    End If 

    'copy headings and paste to new sheet starting in B1 
    With Sheets(2) 
     Range(.Range("A1"), .Cells(1, Columns.Count).End(xlToLeft)).Copy wsNew.Range("B1") 
    End With 

    ' work through sheets 
    For J = 2 To Sheets.Count ' from sheet 2 to last sheet 
     'save sheet name/location to string 
     Location = Sheets(J).Name 

     'set range to be copied 
     With Sheets(J).Range("A1").CurrentRegion 
      Set rngCopy = .Offset(1, 0).Resize(.Rows.Count - 1) 
     End With 

     'set range to paste to, beginning with column B 
     Set rngPaste = wsNew.Cells(Rows.Count, 2).End(xlUp).Offset(2, 0) 

     'copy range and paste to column *B* of combined sheet 
     rngCopy.Copy rngPaste 

     'enter the location name in column A for all copied entries 
     Range(rngPaste, rngPaste.End(xlDown)).Offset(0, -1) = Location 

    Next J 
End Sub 

Answer 1

您可以將此代碼添加到您的個人宏工作簿中，並對其進行修改，使其在ActiveWorkbook上進行操作。這樣，當您運行它時，它將在Excel中選擇的任何工作簿上運行。

另外值得一預選賽與工作簿對象引用您的所有表引用。當您使用（例如）：

Sheets("Combined") 

然後默認情況下，它將引用ActiveWorkbook。通常這是你想要的（雖然可能不是這樣），但是如果（例如）你在你的代碼中打開/激活一個不同的工作簿，並且其他工作簿現在成爲你的參考目標，這種工作方式可能會導致問題。您可以通過始終是明確的解決此哪些工作簿你指的是：例如 -

ThisworkBook.Sheets()    'the workbook containing the running code 
ActiveWorkbook.Sheets()   'the selected workbook 
Workbooks("test.xlsx").Sheets() 'named workbook 
wb.Sheets()      'use a variable set to a workbook object 

因此，修改現有的代碼：

Sub Combine() 
    Dim wb As Workbook 
    Dim J As Integer, wsNew As Worksheet 
    Dim rngCopy As Range, rngPaste As Range 
    Dim Location As String 

    Set wb = ActiveWorkbook 

    On Error Resume Next 
    Set wsNew = wb.Sheets("Combined") 
    On Error GoTo 0 
     'if sheet does not already exist, create it 
     If wsNew Is Nothing Then 
     Set wsNew = wb.Worksheets.Add(before:=wb.Sheets(1)) ' add a sheet in first place 
     wsNew.Name = "Combined" 
    End If 

    'copy headings and paste to new sheet starting in B1 
    With wb.Sheets(2) 
     .Range(.Range("A1"), .Cells(1, Columns.Count) _ 
        .End(xlToLeft)).Copy wsNew.Range("B1") 
    End With 

    ' work through sheets 
    For J = 2 To wb.Sheets.Count ' from sheet 2 to last sheet 
     'save sheet name/location to string 
     Location = wb.Sheets(J).Name 

     'set range to be copied 
     With wb.Sheets(J).Range("A1").CurrentRegion 
      Set rngCopy = .Offset(1, 0).Resize(.Rows.Count - 1) 
     End With 

     'set range to paste to, beginning with column B 
     Set rngPaste = wsNew.Cells(Rows.Count, 2).End(xlUp).Offset(2, 0) 

     'copy range and paste to column *B* of combined sheet 
     rngCopy.Copy rngPaste 

     'enter the location name in column A for all copied entries 
     wsNew.Range(rngPaste, rngPaste.End(xlDown)).Offset(0, -1) = Location 

    Next J 

End Sub