VBA - 新しいワークブックに情報をコピー

Question

私は信じられないほど簡単に聞こえることをしようとしていますが、既存のVBAコードにどのように適合させるかはわかりません。以下のコードはピボットテーブルを一度に1つずつ繰り返し、そのピボットテーブルのデータを新しいワークブックにコピーしてスタッフにメールします

私が追加する必要があるのは、コピーするだけです（単なる値と書式）ピボットテーブルと同じシートのE15：S16の範囲にある13x2のテーブルをタブの新しいワークブックに追加します。「月間予測」と名付けました。私はそれように、コードにこれを取得するかどうかはわかりません、ループなどの別のタブにコピーピボットデータ、その後、毎月の予測を理にかなって

希望で、任意のヘルプは素晴らしい:)

だろう

Option Explicit 

Sub PivotSurvItems() 
Dim i As Integer 
Dim sItem As String 
Dim sName As String 
Dim sEmail As String 
Dim OutApp As Object 
Dim OutMail As Object 

Application.ScreenUpdating = False 
Application.Calculation = xlCalculationManual 
Application.DisplayAlerts = False 

With ActiveSheet.PivotTables("PivotTable1") 
    .PivotCache.MissingItemsLimit = xlMissingItemsNone 
    With .PivotFields("Staff") 
     '---hide all items except item 1 
     .PivotItems(1).Visible = True 
     For i = 2 To .PivotItems.Count 
      .PivotItems(i).Visible = False 
     Next 
     For i = 1 To .PivotItems.Count 
      .PivotItems(i).Visible = True 
      If i <> 1 Then .PivotItems(i - 1).Visible = False 
      sItem = .PivotItems(i) 
      ActiveSheet.PivotTables("PivotTable1").PivotSelect "", xlDataAndLabel, True 
      Selection.Copy 
      Workbooks.Add 

      With ActiveWorkbook 

       .Sheets(1).Cells(1).PasteSpecial _ 
       Paste:=xlPasteValuesAndNumberFormats 
       Worksheets("Sheet1").Columns("A:R").AutoFit 
       ActiveSheet.Range("A2").AutoFilter 
       sName = Range("C" & 2) 
       sEmail = Range("N" & 2) 

       Columns(1).EntireColumn.Delete 
       Columns(2).EntireColumn.Delete 
       Columns(2).EntireColumn.Delete 
       Columns(2).EntireColumn.Delete 
       Columns(10).EntireColumn.Delete 

       ActiveSheet.Name = "FCW" 

       Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Monthly Forecast" 

       Worksheets("FCW").Activate 

      'create folder 
       On Error Resume Next 
       MkDir "C:\Temp\FCW" & "\" & sName 
       On Error GoTo 0 


       .SaveAs "C:\Temp\FCW" & "\" & sName & "\" & sItem & " " & Format(Now(), "DD-MM-YYYY") & ".xlsx", _ 
        FileFormat:=xlOpenXMLWorkbook 

        Set OutApp = CreateObject("Outlook.Application") 
         Set OutMail = OutApp.CreateItem(0) 

         On Error Resume Next 
         With OutMail 
          .To = sEmail 
          .CC = "" 
          .BCC = "" 
          .Subject = "Planning Spreadsheet" 
          .Attachments.Add ActiveWorkbook.FullName 
          .Send 
         End With 
         On Error GoTo 0 

         Set OutMail = Nothing 
         Set OutApp = Nothing 



       .Close 
      End With 


     Next i 
    End With 
End With 

Application.ScreenUpdating = True 
Application.Calculation = xlCalculationAutomatic 
Application.DisplayAlerts = True 

End Sub 

Answer 1

ピボットテーブル内のすべてのアイテムの視認性とサイクリングを変更する代わりに、値を 'テーブル'（範囲）に割り当てて、移動先に渡します（Excelの.copyを使用するよりもずっと速くなります） VBAの.PasteSpecial

また、すべてのデータを「出力」ワークシートにコピーすることをお勧めします同じブック。すべてのデータがコピーされたら、その特定の出力ワークシートを新しいワークブックにエクスポートします。このように、2つの異なるブック間でデータをコピーして貼り付けることを避けることができます。

あなたのコードで

、私はTempフォルダの作成までダウンサイクリングアイテムからすべてを削除し、以下のようなもので、それに代わる：

'Copy values 
    Set rStartCell = ActiveSheet.Range("A1") 'Specify the top-left corner cell of the data you wish to copy 
    Set rTable_1 = ActiveSheet.Range(rStartCell, ActiveSheet.Range("Z" & rStartCell.End(xlDown).Row)) 'Change the Z column to the last column of the data you wish to copy. You can automate this by using something like Range(A1).end(xltoright).columns.count formula to grab the number of columns. 
    Debug.Print "rTable_1: " & rTable_1.Address & " -> " & rTable_1.Rows.Count & " x " & rTable_1.Columns.Count 'good to test exactly what you're copying 

    'Paste Values 
    Set rStartCell = Outputs.Range("A1") 'Change A1 to the cell of where you want to paste on the Outputs worksheet in your original workbook. 
    Set rTable_2 = Outputs.Range(rStartCell, rStartCell.Offset(rTable_1.Rows.Count - 1, rTable_1.Columns.Count - 1)) 
    Debug.Print "rTable_2: " & rTable_2.Address & " -> " & rTable_2.Rows.Count & " x " & rTable_2.Columns.Count 
    rTable_2.Value = rTable_1.Value 
    rTable_1.Copy 
    rTable_2.PasteSpecial Paste:=xlPasteFormats 'to copy/paste those formats you need 

    'Copy Worksheet and open it in a new workbook 
    ThisWorkbook.Sheets("NAME OF OUTPUTS SHEET").Copy 'Using ThisWorkbook to point to the workbook holding this code. 
    ActiveSheet.Name = "FCW" 

あなたは、他のテーブルをコピー/ペーストするために、このメソッドを使用することができます同様に述べた。