这似乎是一个简单的问题,所以我很抱歉,如果我能够在搜索中找到它,但没有一个答案能够帮助我。我正在寻找一种方法来复制范围A1:D14并将其保存在一个新的工作簿中,其中只有格式和值保存到新工作簿。
所以基本上我有一系列数据,其中有很多公式和值来自其他工作表,但是当我的当前代码保存它时,它必须做一些奇怪的删除方法,它当前保存所有数据,这意味着值显示,但当我点击它们时,它是里面的公式而不是实际数据。
Sub SaveData()
Dim SaveFile As String
Dim Title As String
Title = "DigitalStorage"
SaveFile = Application.GetSaveAsFilename(InitialFileName:=Title & "_" & Format(Now, "yyyy-MM-dd hh-mm-ss"), _
fileFilter:="Excel Workbooks (*.xlsx),*.xlsx")
ThisWorkbook.Worksheets("SaveSheet").Copy
With ActiveWorkbook
With .Worksheets("SaveSheet")
ThisWorkbook.Sheets(1).Range("A1:D14").Copy
.Columns("E:ABC").EntireColumn.Delete
.Rows("14:100").EntireRow.Delete
End With
.SaveAs Filename:=SaveFile, FileFormat:=xlOpenXMLWorkbook
.Close savechanges:=False
End With
结束子
我已经尝试添加行复制工作表和PasteSpecial XlValues,但这似乎覆盖了我的原始工作簿,我只想在普通的xlsx文件中的值和格式。而且我也觉得我的代码很笨拙和复杂,并且有一种更简单的方法可以解决这个问题,看起来与我的方法完全不同。
试试这段代码,阅读里面的评论,找一下<<<< Customize this >>>行:
Sub SaveData()
' Declare objects
Dim sourceWorkbook As Workbook
Dim targetWorkbook As Workbook
Dim sourceRange As Range
Dim targetRange As Range
Dim cellRange As Range
' Declare other variables
Dim targetWorkbookName As String
Dim targetWorkbookTitle As String
Dim sourceSheetName As String
Dim sourceRangeAddress As String
Dim targetRangeAddress As String
Dim rowCounter As Long
' <<< Customize this >>>
sourceSheetName = "SaveSheet" ' Name of the source sheet
sourceRangeAddress = "A1:D14" ' Address of the range you want to copy in the source workbook
targetRangeAddress = "A2" ' Cell address where you want to paste the copied range
targetWorkbookTitle = "DigitalStorage" ' Base file name
' Reference source workbook
Set sourceWorkbook = ThisWorkbook
' Create a new workbook
Set targetWorkbook = Application.Workbooks.Add
' Set reference to source range
Set sourceRange = sourceWorkbook.Sheets(sourceSheetName).Range(sourceRangeAddress)
' Copy the range to clipboard
sourceRange.Copy
' This copies the range in the first available worksheet begining in the cell address specified
targetWorkbook.Sheets(1).Range(targetRangeAddress).PasteSpecial Paste:=xlPasteValues
targetWorkbook.Sheets(1).Range(targetRangeAddress).PasteSpecial Paste:=xlPasteFormats
targetWorkbook.Sheets(1).Range(targetRangeAddress).PasteSpecial Paste:=xlPasteColumnWidths
Set targetRange = targetWorkbook.Sheets(1).Range(targetRangeAddress).Resize(sourceRange.Rows.Count, sourceRange.Columns.Count)
' Adjust row heights
For Each cellRange In sourceRange.Columns(1).Cells
rowCounter = rowCounter + 1
targetRange.Rows(rowCounter).RowHeight = cellRange.RowHeight
Next cellRange
' Set the name of the new workbook
targetWorkbookName = Application.GetSaveAsFilename(InitialFileName:=targetWorkbookTitle & "_" & Format(Now, "yyyy-MM-dd hh-mm-ss"), _
fileFilter:="Excel Workbooks (*.xlsx),*.xlsx")
If targetWorkbookName = vbNullString Then
MsgBox "Saving operation canceled"
Exit Sub
End If
' Save the new workbook
targetWorkbook.SaveAs Filename:=targetWorkbookName ' Un comment this if you want it in OpenXML format: , FileFormat:=xlOpenXMLWorkbook
' Close the new saved workbook (in this line couldn't figure out if you wanted to close the new or the old workbook
targetWorkbook.Close ' savechanges:=False
End Sub