为多个文件粘贴特殊转置

Question

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

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

此后，它将返回主工作簿并在单独的新工作表中进行特殊粘贴。例如，workbookA1 的数据进入 Sheet1，workbookA2 的数据进入 Sheet2。但是，我遇到了一些麻烦。错误提示“PasteSpecial 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

试试这个，它会删除 Selects 和 Activates，并将复制的范围限制为使用的范围，而不是每个单元格。我想我已经正确地解释了你的场景，但如果没有，请大喊。

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