Question

我尝试将多张图表合并到一张图纸中，并为最终版本添加一个新列＆＃34;合并＆＃34;片。新工作表应该有一个名为＆＃34; Source＆＃34;使用工作表名称复制后面的行。

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”重命名新创建的工作表时，它就会出现，并且工作簿中已存在具有此名称的工作表。结果是代码跳过这一行，工作表的名称保留了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

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

一张源表
一个用于源文件

试一试：

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

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

2 个答案: