将源表单名称包含在输出表单中

我正在尝试将多个工作表合并到一个工作表中，并为最终的“合并”工作表添加一个新列。 新的工作表应该有一个名为“Source”的列，其中后面的行被复制。

Sub Final() Path = " " Filename = Dir(Path & "*.csv") Do While Filename <> "" Workbooks.Open Filename:=Path & Filename, ReadOnly:=True For Each Sheet In ActiveWorkbook.Sheets Sheet.Copy After:=ThisWorkbook.Sheets(1) Next Sheet Workbooks(Filename).Close Filename = Dir() Loop Dim J As Integer On Error Resume Next Sheets(1).Select Worksheets.Add Sheets(1).Name = "Combined" Sheets(2).Activate Range("A1").EntireRow.Select Selection.Copy Destination:=Sheets(1).Range("A1") For J = 2 To Sheets.Count Sheets(J).Activate Range("A1").Select Selection.CurrentRegion.Select Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2) Next End Sub 

在此先感谢您的帮助球员:)

Answer 1

下面的代码将在For J = 2 To ThisWorkbook.Sheets.Count循环内复制工作表的名称到列B（等同于数据的第一个空行存在于列A中）。

没有Select ， Selection和ActiveWorkbook ，而是有完全限定的对象，如Workbooks ， Worksheets和Range 。

此外，使用On Error Resume Next还应该尝试查看错误来自何处，以及如何处理它。 在你的情况下，它试图重新命名名称为“Combined”的新创build的工作表，并且工作簿中已经有一个工作表。 结果是代码跳过这一行，并且工作表的名字保持与Excel给出的默认名称（即“Sheet”和第一个可用的索引号）。

码

 Option Explicit Sub Final() Dim wb As Workbook Dim Sheet As Worksheet Dim Path As String, FileName As String Dim J As Long Path = " " FileName = Dir(Path & "*.csv") Do While FileName <> "" Set wb = Workbooks.Open(FileName:=Path & FileName, ReadOnly:=True) For Each Sheet In wb.Sheets Sheet.Copy after:=ThisWorkbook.Sheets(1) Next Sheet wb.Close Set wb = Nothing FileName = Dir() Loop On Error Resume Next Set Sheet = Worksheets.Add(after:=Sheets(1)) Sheet.Name = "Combined" If Err.Number <> 0 Then Sheet.Name = InputBox("Combined already exists in workbook, select a different name", "Select new created sheet's name") End If On Error GoTo 0 Sheets(2).range("A1").EntireRow.Copy Sheets(1).range("A1") For J = 2 To ThisWorkbook.Sheets.Count With Sheets(J) .Range("A1").CurrentRegion.Offset(1, 0).Resize(.Range("A1").CurrentRegion.Rows.Count - 1, .Range("A1").CurrentRegion.Columns.Count).Copy _ Destination:=Sheets(1).Range("A65536").End(xlUp) Sheets(1).Range("B" & Sheets(1).Cells(Sheets(1).Rows.Count, "A").End(xlUp).Row).Value = .Name '<-- copy the sheet's name to column B End With Next J End Sub 

Answer 2

这将创build一个新工作表或清理现有工作表并添加2列：

• 一个用于源表单
• 一个用于源文件

试一下 ：

 Sub Test_Matt() Dim BasePath As String Dim FileName As String Dim tB As Workbook Dim wB As Workbook Dim wS As Worksheet Dim wSCopied As Worksheet Dim LastRow As Double Dim ColSrcShtCombi As Integer Dim ColSrcWbCombi As Integer Dim wSCombi As Worksheet Dim NextRowCombi As Double Dim J As Integer Set tB = ThisWorkbook On Error Resume Next Set wSCombi = tB.Sheets("Combined") If wSCombi Is Nothing Then Set wSCombi = tB.Sheets.Add wSCombi.Name = "Combined" Else wSCombi.Cells.Clear End If On Error GoTo 0 With wSCombi '''I don't know which sheet that is your take your headers from, '''but here is where to define it: tB.Sheets(2).Range("A1").EntireRow.Copy Destination:=wSCombi.Range("A1") '''Add "Source"s columns ColSrcShtCombi = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1 .Cells(1, ColSrcShtCombi).Value = "Source Sheet" ColSrcWbCombi = ColSrcShtCombi + 1 .Cells(1, ColSrcWbCombi).Value = "Source Workbook" End With '''Define here the folder you want to scan: BasePath = "C:\Example\" FileName = Dir(BasePath & "*.csv") Do While FileName <> vbNullString Set wB = Workbooks.Open(FileName:=BasePath & FileName, ReadOnly:=True) For Each wS In wS.Sheets Set wSCopied = wS.Copy(After:=tB.Sheets(tB.Sheets.Count)) '''Find next available row in Combined sheet NextRowCombi = wSCombi.Range("A" & wSCombi.Rows.Count).End(xlUp).Row + 1 With wSCopied '''Find the last row of data in that sheet LastRow = .Range("A" & .Rows.Count).End(xlUp).Row '''Copy the data in Combined sheet .Range("A2", .Cells(LastRow, .Cells(1, .Columns.Count).End(xlToLeft).Column)).Copy _ Destination:=wSCombi.Range("A" & NextRowCombi) '''Put sheet's name and workbook's name in source columns wSCombi.Range(wSCombi.Cells(NextRowCombi, ColSrcShtCombi), wSCombi.Cells(NextRowCombi + LastRow - 1, ColSrcShtCombi)).Value = wS.Name wSCombi.Range(wSCombi.Cells(NextRowCombi, ColSrcWbCombi), wSCombi.Cells(NextRowCombi + LastRow - 1, ColSrcWbCombi)).Value = wB.Name End With 'wSCopied Next wS wB.Close FileName = Dir() Loop End Sub