COPY WORKSHEET To Another Workbook

[gamefunza]

คือผม มี Form อยู่ Form นึง ที่ต้องการคือ ใช้ Macro Save As เป็นไฟลใหม่โดย ตั้งชื่อตาม CELL ที่กำหนด เช่น FileName1 = Range("B1").Text

ปัญหา : Code ที่ผมเขียนเนี่ย มัน Save ไปแค่ Value แต่ละ Cell เท่านั้น Shape หรือ รูปภาพ นั้นไม่ตามมาด้วย
จุดที่อยากให้ Guide : ตอนนี้ผมทำได้แค่ กำหนด Range ที่ต้องการ แต่ที่คิดไว้คือ Copy ทั้ง Worksheet เหมือนเป๊ะไม่ว่าจะเป็นตำแหน่ง Colum Row รูปภาพ ให้ Fix อยู่ใน แผ่นเดียว

ปล. เอกสารที่แนบไปไม่ใช้เอกสารจริงนะครับ เพราะเป็นข้อมูลสำคัญครับ ขอบคุณมากครับ



Code

Code: Select all

Option Explicit

Sub Sample()

'~~> Set workbook In/Out
'~~> Set worksheet In/Out


    Dim wbI As Workbook, wbO As Workbook
    Dim wsI As Worksheet, wsO As Worksheet
    Dim Path As String
    Dim FileName1 As String
    
    '~~> Set FileName

  Path = "D:\Baramee\"
  FileName1 = Range("B1").Text

    '~~> Set workbook
    Set wbI = ThisWorkbook
    '~~>  Set worksheet
    Set wsI = wbI.Sheets("Sheet1")

    '~~> Set  workbook Des
    Set wbO = Workbooks.Add
    
    With wbO
        '~~> Set  WS Out
        Set wsO = wbO.Sheets("Sheet1")

        '~~>. Save the file  51 = xlOpenXMLWorkbook (without macro's in 2007-2016, xlsx)
        '~~>                      52 = xlOpenXMLWorkbookMacroEnabled (with or without macro's in 2007-2016, xlsm)
        '~~>                      50 = xlExcel12 (Excel Binary Workbook in 2007-2016 with or without macro's, xlsb)
        '~~>                      56 = xlExcel8 (97-2003 format in Excel 2007-2016, xls)
                                     
                                     
   '////////////////////////////////////////////////////////////////////////
                                
 '~~> .SaveAs Filename:="D:\Book10.xls", FileFormat:=56


        .SaveAs FileName:=Path & FileName1, FileFormat:=56
        
    
        '~~> Set Range
        
        wsI.Range("A2:F19").Copy

        '~~> Paste
        
        wsO.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        
    End With
End Sub

[puriwutpokin]

ปรับโค้ดตามนี้ดูครับ

Code: Select all

Sub Sample()

'~~> ประกาศ workbook In/Out
'~~> ประกาศ worksheet In/Out



    Dim wbI As Workbook, wbO As Workbook
    Dim wsI As Worksheet, wsO As Worksheet
    Dim Path As String
    Dim FileName1 As String
    
    '~~> กำหนด FileName

  Path = "D:\Baramee\"
  FileName1 = Range("B1").Text

    '~~> กำหนด workbook
    Set wbI = ThisWorkbook
    '~~>  กำหนด worksheet
    Set wsI = wbI.Sheets("Sheet1")
wsI.Copy
    '~~> กำหนดปลายทาง workbook
    'Set wbO = Workbooks.Add
    
    'With wbO
        '~~> กำหนดตำแหน่ง WS ที่ต้องการวาง
       ' Set wsO = wbO.Sheets("Sheet1")

        '~~>. Save the file  51 = xlOpenXMLWorkbook (without macro's in 2007-2016, xlsx)
        '~~>                      52 = xlOpenXMLWorkbookMacroEnabled (with or without macro's in 2007-2016, xlsm)
        '~~>                      50 = xlExcel12 (Excel Binary Workbook in 2007-2016 with or without macro's, xlsb)
        '~~>                      56 = xlExcel8 (97-2003 format in Excel 2007-2016, xls)
                                     
                                     
   '////////////////////////////////////////////////////////////////////////
                                
 '~~> .SaveAs Filename:="D:\Book10.xls", FileFormat:=56


    ActiveWorkbook.SaveAs Filename:=Path & FileName1, FileFormat:=56
        
    
        '~~> Range ที่สนใจ
        
        'wsI.Range("A2:F19").Copy

        '~~> วางเริ่มต้น จาก Cell A1  No SkipBlank  No Transpose
        
        'wsO.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        
    'End With
End Sub

[gamefunza]

ขอบคุณมากครับ