VBA - 将信息复制到新的工作簿
问题描述:
我正在尝试做一些听起来非常简单的事情,但我无法弄清楚如何使其适合现有的VBA代码。下面的代码一次循环数据透视表1项,并将表中的数据复制到新的工作簿并发送给工作人员电子邮件VBA - 将信息复制到新的工作簿
我需要添加的所有内容都是为了复制(只是值和格式设置)在数据透视表的同一工作表中将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
答
而不是更改数据透视表中所有项目的可见性和循环,将值分配给“表”(范围)并将其传递到您想要的位置(这比使用Excel的.copy
和.PasteSpecial
in VBA。
此外,我建议您将所有数据复制到“输出”工作表中e相同的工作簿。当所有数据都被复制后,将该特定输出工作表导出到新的工作簿中。这样可以避免在两个不同的工作簿之间复制和粘贴数据,这些工作簿可能容易出错。
在代码中,我会从项目循环,直至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"
您可以使用此方法复制/粘贴等表也提到了。