Question

首先，我从拥有主文件开始。主文件包含40个其他工作簿的名称。

我需要编写一个适用于这40个工作簿的VBA代码（在masterfile中的A1-A40中定义的名称）。此代码应转到每个工作簿，打开它，并将数据复制到每个工作簿的第一个工作表中。

此后，它将返回到主工作簿并将其粘贴到单独的新工作表中。例如，workbookA1的数据进入Sheet1，而workbookA2的数据进入Sheet2。但是，我遇到了一些麻烦。错误说“RangeSpecial Method of Range Class”失败。

Sub Macro2()
    Dim thiswb As Workbook, datawb As Workbook
    Dim datafolder As String
    Dim cell As Range, datawblist As Range
    Dim i As Integer

    Set thiswb = ActiveWorkbook
    i = 2
    'Have the 40 file names in sheet2 of this workbook in cells A1:A40
    Set datawblist = Sheets("command").Range("A1:A4")
    datafolder = "C:\Users\bryan\Desktop\Y4S1\Money and Banking\Empirical\QuarterSheets\2012q1\" 'change this to your directory they're in
    For Each cell In datawblist
        Workbooks.Open Filename:=datafolder & cell & ".csv", ReadOnly:=True
        Set datawb = ActiveWorkbook
        Sheets(1).Select 'change this to the sheet name you need to copy from
        Range("A1:XFD1048576").Select
        Do Until ActiveCell.Value = ""
            Selection.Copy
            ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
            thiswb.Activate
            ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
            Selection.PasteSpecial Paste:=xlPasteValues, _
                Operation:=xlNone, _
                SkipBlanks:=False, _
                Transpose:=True
            ActiveCell.Offset(0, 4).Select
            datawb.Activate
            ActiveCell.Offset(0, 1).Select
        Loop
        datawb.Close savechanges:=False
        thiswb.Activate
        Sheets("command").Select
        i = i + 1
        Cells(i, 1).Select
    Next

End Sub

Answer 1

尝试此操作，删除选择和激活，并将复制的范围限制为使用的范围而不是每个单元格。我想我已经正确地解释了你的情景，但是如果没有那么大喊。

Sub Macro2()

Dim thiswb As Workbook, datawb As Workbook, ws As Worksheet
Dim datafolder As String
Dim cell As Range, datawblist As Range
Dim i As Long

Set thiswb = ThisWorkbook
i = 2
'Have the 40 file names in sheet2 of this workbook in cells A1:A40
Set datawblist = thiswb.Sheets("command").Range("A1:A4")
datafolder = "C:\Users\bryan\Desktop\Y4S1\Money and Banking\Empirical\QuarterSheets\2012q1\" 'change this to your directory they're in

For Each cell In datawblist
    Set datawb = Workbooks.Open(Filename:=datafolder & cell & ".csv", ReadOnly:=True)
    Set ws = thiswb.Sheets.Add(After:=thiswb.Worksheets(Worksheets.Count))
    datawb.Sheets(1).UsedRange.Copy
    ws.Range("A1").PasteSpecial Paste:=xlPasteValues, _
        Operation:=xlNone, _
        SkipBlanks:=False, _
        Transpose:=True
    datawb.Close savechanges:=False
Next

End Sub

为多个文件粘贴特殊转置

1 个答案: