Excel VBA 다른 통합 문서로 그림/차트 복사

Question

현재 통합 문서의 필드를 가져 와서 다른 통합 문서로 복사하는 코드가 있습니다. 나는 현재 범위와 '스냅 샷'을 취한 다음 별도의 .bmp 파일로 저장합니다.

이 스냅 샷을 통합 문서의 셀에 첨부하여 모든 것을 복사하고 싶습니다. 아무도 어떤 조언을, 또는 여기에 내가이 코드를 추가 할 수 있습니다 참조하십시오?

Sub Macro4() 

' '기록 및 파일 보고서

Dim Model As String 
Dim IssueDate As String 
Dim ConcernNo As String 
Dim IssuedBy As String 
Dim FollowedSEC As String 
Dim FollowedBy As String 
Dim RespSEC As String 
Dim RespBy As String 
Dim Timing As String 
Dim Title As String 
Dim PartNo As String 
Dim Block As String 
Dim Supplier As String 
Dim Other As String 
Dim Detail As String 
Dim CounterTemp As String 
Dim CounterPerm As String 
Dim VehicleNo As String 
Dim OperationNo As String 
Dim Line As String 
Dim Remarks As String 
Dim ConcernMemosMaster As Workbook 
Dim LogData As String 
Dim newFile As String 
Dim fName As String 
Dim Filepath As String 
Dim DTAddress As String 
Dim pic_rng As Range 
Dim ShTemp As Worksheet 
Dim ChTemp As Chart 
Dim PicTemp As Picture 

'Determines if any required cells are empty and stops process if there are. displays error message. 
If IsEmpty(Range("c2")) Or IsEmpty(Range("AT3")) Or IsEmpty(Range("BI2")) Or IsEmpty(Range("M7")) Or IsEmpty(Range("C10")) Or IsEmpty(Range("AP14")) Or IsEmpty(Range("C14")) Or IsEmpty(Range("C23")) Or IsEmpty(Range("C37")) Or IsEmpty(Range("J51")) Or IsEmpty(Range("AA51")) Or IsEmpty(Range("C55")) Or IsEmpty(Range("AR51")) Then 
MsgBox "Please fill out all required fields and retry.", vbOKOnly 
Exit Sub 
End If 

If Dir("N:\") = "" Then '"N" drive not found, abort sub 
MsgBox "Error: Drive, path or file not found. Please email copy of file to: " 
Exit Sub 
End If 

'assigns fields 
Worksheets("ConcernMemo").Select 
Model = Range("c2") 
IssueDate = Range("AT3") 
ConcernNo = Range("BC3") 
IssuedBy = Range("BI2") 
FollowedSEC = Range("BA9") 
FollowedBy = Range("BD9") 
RespSEC = Range("BG9") 
RespBy = Range("BJ9") 
Timing = Range("M7") 
Title = Range("C10") 
PartNo = Range("AP14") 
Block = Range("AP16") 
Supplier = Range("AP18") 
Other = Range("AZ14") 
Detail = Range("C14") 
CounterTemp = Range("C23") 
CounterPerm = Range("C37") 
VehicleNo = Range("J51") 
OperationNo = Range("AA51") 
Remarks = Range("C55") 
Line = Range("AR51") 
LogData = Format(Now(), "mm_dd_yyyy_hh_mmAMPM") 
fName = Range("BC3").Value 
newFile = fName & "_" & Format(Now(), "mmddyyyy_hhmmAMPM") 
Filepath = "N:\Newell K\Concern_Memo\Concern_Memo_File_Drop\Concern_Memo_Records\" & fName & "_" & Format(Now(), "mmddyyyy_hhmmAMPM") 
DTAddress = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator 


    'asks user is they are ready to send to database 
If MsgBox("Are you ready to send record to database?", vbYesNo) = vbNo Then Exit Sub 
Application.ScreenUpdating = False 
Application.DisplayAlerts = False 

Set pic_rng = Worksheets("ConcernMemo").Range("AK22:BK49") 
Set ShTemp = Worksheets.Add 

    'Takes snapshot of image/sketch and saves to sharedrive 
Charts.Add 
ActiveChart.Location Where:=xlLocationAsObject, Name:=ShTemp.Name 
Set ChTemp = ActiveChart 
pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture 
ChTemp.Paste 
Set PicTemp = Selection 
With ChTemp.Parent 
.Width = PicTemp.Width + 8 
.Height = PicTemp.Height + 8 
End With 
ChTemp.Export fileName:="N:\Newell K\Concern_Memo\Concern_Memo_File_Drop\Concern_Memo_Images\" & newFile & ".bmp", FilterName:="bmp" 

ShTemp.Delete 


    'opens db file on sharedrive and copies fields over 
Set ConcernMemosMaster = Workbooks.Open("N:\Newell K\Concern_Memo\concern_memos_DBMASTER.xlsx") 
Worksheets("sheet1").Select 
Worksheets("sheet1").Range("a1").Select 
RowCount = Worksheets("sheet1").Range("a1").CurrentRegion.Rows.Count 
With Worksheets("sheet1") 
.Range("a1").Offset(RowCount, 0) = Model 
.Range("b1").Offset(RowCount, 0) = IssueDate 
.Range("c1").Offset(RowCount, 0) = ConcernNo 
.Range("d1").Offset(RowCount, 0) = IssuedBy 
.Range("e1").Offset(RowCount, 0) = FollowedSEC 
.Range("f1").Offset(RowCount, 0) = FollowedBy 
.Range("g1").Offset(RowCount, 0) = RespSEC 
.Range("h1").Offset(RowCount, 0) = RespBy 
.Range("i1").Offset(RowCount, 0) = Timing 
.Range("j1").Offset(RowCount, 0) = Title 
.Range("k1").Offset(RowCount, 0) = PartNo 
.Range("l1").Offset(RowCount, 0) = Block 
.Range("m1").Offset(RowCount, 0) = Supplier 
.Range("n1").Offset(RowCount, 0) = Other 
.Range("o1").Offset(RowCount, 0) = Detail 
.Range("p1").Offset(RowCount, 0) = CounterTemp 
.Range("q1").Offset(RowCount, 0) = CounterPerm 
.Range("r1").Offset(RowCount, 0) = VehicleNo 
.Range("s1").Offset(RowCount, 0) = OperationNo 
.Range("t1").Offset(RowCount, 0) = Remarks 
.Range("U1").Offset(RowCount, 0) = PicTemp 
.Range("V1").Offset(RowCount, 0) = LogData 
.Range("w1").Offset(RowCount, 0) = Filepath 
.Range("x1").Offset(RowCount, 0) = Line 

    'saves a copy to of entire file to sharedrive 
ThisWorkbook.SaveCopyAs fileName:="N:\Newell K\Concern_Memo\Concern_Memo_File_Drop\Concern_Memo_Records\" & newFile & ".xlsm" 

    'Saves copy to desktop 
Application.DisplayAlerts = True 
ThisWorkbook.SaveCopyAs DTAddress & newFile & ".xlsm" 
MsgBox "A copy has been saved to your desktop" 
ThisWorkbook.SendMail Recipients:="kaitlin.newell@nissan-usa.com", _ 
          Subject:="New Concern Memo" 


End With 



ConcernMemosMaster.Save 
ConcernMemosMaster.Close 

Application.DisplayAlerts = True 

MsgBox "Please close out file without saving" 


End Sub 

Answer 1

이 밖으로 시도 :

Range("A1:D4").CopyPicture Appearance:=xlScreen, Format:=xlBitmap 
Range("A6").PasteSpecial 

이 셀 A6에서 Range("A1:D4")의 "스냅 샷"의 사본을 붙여 넣습니다.

---

편집 : 당신은 이미 "대상"통합 문서의 객체를 설정 한 이후, 당신은 쉽게에 붙여 사용할 수 있습니다. 이것을 시도하십시오 :

ConcernMemosMaster.Worksheets("sheet1").Range("A1:X1").CopyPicture Appearance:=xlScreen, Format:=xlBitmap 
ConcernMemosMaster.Worksheets("sheet1").Range("B1").PasteSpecial