VBA将行粘贴为图像
只是有一个关于粘贴的快速问题。我有一个脚本，可以将各行导出到新创建的工作簿中。然而，问题是粘贴的值是以图像的形式存在的。此外，将跳过注释。我使用相同的代码粘贴到同一工作簿的其他工作表中，没有问题 我似乎找不到原因。任何帮助都将不胜感激 谢谢VBA将行粘贴为图像,vba,excel,Vba,Excel,只是有一个关于粘贴的快速问题。我有一个脚本，可以将各行导出到新创建的工作簿中。然而，问题是粘贴的值是以图像的形式存在的。此外，将跳过注释。我使用相同的代码粘贴到同一工作簿的其他工作表中，没有问题 我似乎找不到原因。任何帮助都将不胜感激 谢谢 Private Sub DC_1Month_Button_Click() 'Searches for crews working on MFDC (7343) and exports a new spreadsheet looking 3 weeks ahe
Private Sub DC_1Month_Button_Click()
'Searches for crews working on MFDC (7343) and exports a new spreadsheet looking 3 weeks ahead for each person
If MsgBox("Export DC individual schedules?") = vbNo Then
Exit Sub
End If
On Error GoTo CleanFail
Dim nowCol As Integer, lastCol As Integer, endCol As Integer, crewRow As Integer
Dim masterSheet As Worksheet, newExcel As Object, newBook As Workbook, newSheet As Worksheet
Dim startRow As Integer, endRow As Integer
Dim currentName As String, currentProject As String
startRow = 3
endRow = UsedRange.Row - 1 + UsedRange.Rows.count
lastcoln = UsedRange.Column - 1 + UsedRange.Columns.count
Set masterSheet = ThisWorkbook.Worksheets("Master Schedule")
'Find columns for today and date 3 weeks after
nowCol = Range(Cells(2, 1), Cells(2, lastcoln)).Find(what:=Month(Date) & "/" & Day(Date) & "/" & Year(Date)).Column
endCol = Range(Cells(2, 1), Cells(2, lastcoln)).Find(what:=Month(DateAdd("d", 30, Date)) & "/" & Day(DateAdd("d", 30, Date)) & "/" & Year(DateAdd("d", 30, Date))).Column
'Disable screen flashing while doing copying and exports
Application.ScreenUpdating = False
'Loop through crew members
For i = 3 To endRow
'Store current row's values
currentName = Replace(ActiveSheet.Cells(i, 2).Value, "SA: ", "")
currentProject = ActiveSheet.Cells(i, 3).Value
'Search the value from the Project column for the MFDC project number
If InStr(1, currentProject, "7343") > 0 Then
'Load schedule template
Set newExcel = CreateObject("Excel.Application")
newExcel.DisplayAlerts = False
newExcel.Workbooks.Open "\\VALGEOFS01\SurveyProjectManagers\304Schedule\Templates\DC_3Week_Template.xlsx"
Set newBook = newExcel.Workbooks(1)
Set newSheet = newBook.Worksheets(1)
'Copy and paste header rows
masterSheet.Range(masterSheet.Cells(1, nowCol), masterSheet.Cells(2, endCol)).Copy 'Destination:=newSheet.Range("A1")
Application.Wait (Now + TimeValue("0:00:01"))
newSheet.Range(newSheet.Cells(1, 6), newSheet.Cells(1, endCol - 1)).PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
'Copy and paste crew member's location
masterSheet.Range(masterSheet.Cells(i, 2), masterSheet.Cells(i, 6)).Copy 'Destination:=newSheet.Range("A3")
Application.Wait (Now + TimeValue("0:00:01"))
newSheet.Range("A3").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
'Copy schedule data for crew member
masterSheet.Range(masterSheet.Cells(i, nowCol), masterSheet.Cells(i, endCol)).Copy
Application.Wait (Now + TimeValue("0:00:01"))
newSheet.Cells(3, 6).PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
'Save individual's schedule
With newBook
.Title = currentName & " MFDC Schedule"
.SaveAs Filename:="\\VALGEOFS01\SurveyProjectManagers\304Schedule\MFDC Individual Schedules\" & currentName & " MFDC Schedule " & Format(Date, "yymmdd") & ".xlsx", AccessMode:=xlExclusive, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
.Close (True)
End With
End If
Next i
CleanExit:
MsgBox "Export complete"
'Restore normal screen updating
Application.ScreenUpdating = True
Exit Sub
CleanFail:
If Err.Number <> 0 Then
Msg = "Error # " & Str(Err.Number) & " was generated by " & Err.Source & Chr(13) & Err.Description
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
End If
Resume CleanExit
Resume
End Sub
Private Sub DC\u 1个月\u按钮\u单击（）
“搜索在MFDC（7343）上工作的船员，并为每个人导出一份新的电子表格，展望未来3周的发展
如果MsgBox（“导出DC单独计划？”）=vbNo，则
出口接头
如果结束
出错时转到CleanFail
Dim nowCol为整数，lastCol为整数，endCol为整数，crewRow为整数
Dim masterSheet作为工作表、newExcel作为对象、newBook作为工作簿、newSheet作为工作表
Dim startRow为整数，endRow为整数
将currentName设置为字符串，将currentProject设置为字符串
startRow=3
endRow=UsedRange.Row-1+UsedRange.Rows.count
lastcoln=UsedRange.Column-1+UsedRange.Columns.count
设置主工作表=此工作簿。工作表（“主进度表”）
'查找今天的列和3周后的日期
nowCol=Range（单元格（2，1），单元格（2，lastcoln））.Find（what:=月（日期）&“/”日（日期）&“/”年（日期））列
endCol=Range（单元格（2，1），单元格（2，lastcoln））.Find（what:=月（DateAdd（“d”，30，Date））&“/”和天（DateAdd（“d，30，Date））&“/”和年（DateAdd（“d，30，Date））。列
'在执行复制和导出时禁用屏幕闪烁
Application.ScreenUpdating=False
"环游机组人员,
对于i=3到尾行
'存储当前行的值
currentName=Replace（ActiveSheet.Cells（i，2）.值，“SA:”，“”）
currentProject=ActiveSheet.Cells（i，3）.Value
'从“项目”列中搜索MFDC项目编号的值
如果InStr（1，currentProject，“7343”）>0，则
'加载计划模板
设置newExcel=CreateObject（“Excel.Application”）
newExcel.DisplayAlerts=False
newExcel.Workbooks.Open“\\VALGEOFS01\SurveyProjectManagers\304Schedule\Templates\DC\u 3Week\u Template.xlsx”
Set newBook=newExcel.Workbooks（1）
设置新闻纸=新书。工作表（1）
'复制并粘贴标题行
母版纸.Range（母版纸.Cells（1，nowCol），母版纸.Cells（2，endCol））.Copy'目的地：=新闻纸.Range（“A1”）
Application.Wait（现在+时间值（“0:00:01”））
新闻纸.范围（新闻纸.单元格（1,6），新闻纸.单元格（1,endCol-1））.Paste特殊XLPaste值和数字格式
Application.CutCopyMode=False
'复制并粘贴机组成员的位置
母版纸.范围（母版纸.单元格（i，2），母版纸.单元格（i，6））.Copy'目的地：=新闻纸.范围（“A3”）
Application.Wait（现在+时间值（“0:00:01”））
新闻纸。范围（“A3”）。粘贴特殊粘贴：=XLPasteValues和NumberFormats
Application.CutCopyMode=False
'复制机组成员的计划数据
母版纸。范围（母版纸。单元格（i，nowCol），母版纸。单元格（i，endCol））。复制
Application.Wait（现在+时间值（“0:00:01”））
新闻纸。单元格（3，6）。粘贴特殊粘贴：=xlPasteAll
Application.CutCopyMode=False
'保存个人的日程安排
用纽本
.Title=当前名称和“MFDC计划”
.SaveAs文件名：=“\\VALGEOFS01\SurveyProjectManagers\304Schedule\MFDC单个计划\”¤tName&“MFDC计划”&Format（Date，“yymmdd”）&.xlsx，AccessMode:=xlExclusive，conflictdolution:=Excel.xlsaveconflictdolution.xlLocalSessionChanges
.Close（真）
以
如果结束
接下来我
清洁出口：
MsgBox“导出完成”
'恢复正常屏幕更新
Application.ScreenUpdating=True
出口接头
清除失败：
如果错误号为0，则
Msg=“Error#”&Str（Err.Number）&“由”&Err.Source&Chr（13）&Err.Description生成”
MsgBox Msg，“Error”，Err.HelpFile，Err.HelpContext
如果结束
恢复清除出口
简历
端接头