合并工作表并在Excel中添加列

我有一个工作表，其中包含多个标签，标识不同的数据源。 我需要将所有工作表合并到一个工作表中，并添加一个包含工作表名称的列作为新组合工作表的一部分。

我发现下面的代码，如果我剪切/粘贴到我的工作表，它的作品就像一个魅力，但我有几个这些工作簿，我必须能够每月重新创build此过程。

我的研究表明，我应该创build一个COM添加或可callback的macros来做到这一点，但每次我尝试过，失败的过程。 如果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

您可以将此代码添加到您的个人macros工作簿中，并对其进行修改，以使其在ActiveWorkbook上运行。 这样，当您运行它时，它将在Excel中select的任何工作簿上进行操作。

同样值得使用工作簿对象引用限定所有工作表引用。 当你使用（例如）：

 Sheets("Combined") 

那么默认情况下它会引用ActiveWorkbook 。 通常这是你想要的（虽然可能不是这样），但是如果（例如）你在代码中打开/激活一个不同的工作簿，并且其他工作簿现在是你的Sheets(....)的目标Sheets(....)参考。 您通过始终明确指出所涉及的工作簿来解决此问题：例如，

 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