爲多個文件粘貼特殊轉置

首先，我從擁有主文件開始。主文件具有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個工作表），而其他工作表是傳統的複製和粘貼 –

爲多個文件粘貼特殊轉置

回答

相關問題