为多个文件粘贴特殊转置

首先，我从拥有主文件开始。主文件具有40个其他工作簿的名称。为多个文件粘贴特殊转置

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

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

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

来源

2017-10-06 Bryan Lwy

您尝试从'datawb'复制到'thiswb'，你应该使用它尝试利用它们，并避免使用'activeworkbook'如'ActiveWorkbook.Sheets.Add后：=工作表（Worksheets.Count） ' – Rosetta

打开工作簿时，您可以在一行中设置datawb和workbook.open，即'Set datawb = Workbooks.Open（Filename：= datafolder＆cell＆“.csv”，ReadOnly：= True）''。从而无效混淆activeworkbook主workbok – Rosetta

尝试此，其去除选择并激活，并限制复制的范围所使用的范围，而不是每一个单细胞。我想我已经正确地解释了你的场景，但是如果没有的话就大喊大叫。

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

来源

2017-10-06 13:35:33 SJR

让我试试，尽快回复你 –

转置工作1工作表，但其余的。任何解决方案呢？ –

（粘贴转置工作只有1个工作表），而其他工作表是传统的复制和粘贴 –

为多个文件粘贴特殊转置

回答

相关问题