สร้างไฟล์ใช้ชื่อที่เรากำหนดเองได้

[godman]

สวัสดีครับ อาจารย์ มีเรื่องให้ช่วยเหลือครับ พอดีว่า ความต้องการของผมคือ อยากให้ผู้ใช้งาน กดปุ่ม สร้างไฟล์ โดยผมกำหนดให้ใช้ชื่อไฟล์ตามชื่อใน 2 เซลล์ที่กำหนดไว้ เท่านั้น ผมได้ CODE นี้และอยากจะปรับใช้ แต่ว่ามัน error ครับ ลักษณะ error คือ มันเกี่ยวกับ sheet1 ไม่แน่ใจว่าคืออะไร ต้องรบกวนดูให้ผมด้วยครับ ขอบคุณครับ ผมสร้างปุ่มไว้ที่ชี้ต HOME ส่วนชี้ตที่อยากให้สร้างคือชี้ตชื่อ add_new

Code: Select all

Sub SheetsToNewWorkbook()

   Dim oBaseWkBk    As Workbook
   Dim oNewWkBk     As Workbook
   Dim zSheets(5)   As String
   Dim zNewFileName As String
   Dim iCntr        As Integer
   
   zSheets(0) = "Add_New"
   
    
    Set oBaseWkBk = ActiveWorkbook
    Sheets("Add_New").Select
    zNewFileName = [C6].Value & Format([F7].Value) & ".xls"
    Set oNewWkBk = Workbooks.Add
    Application.DisplayAlerts = False
    oNewWkBk.SaveAs Filename:=zNewFileName, _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    Application.DisplayAlerts = True
    
    
    For iCntr = 0 To UBound(zSheets) - 1
       oBaseWkBk.Activate
       Sheets(zSheets(iCntr)).Copy Before:=Workbooks(oNewWkBk.Name).Sheets("Sheet1")
       On Error GoTo NoCellsSelected
       Selection.SpecialCells(xlCellTypeFormulas, 23).Select
       With Selection
           .Copy
           .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
                  SkipBlanks:=False, Transpose:=False
       End With  'Selection
       Application.CutCopyMode = False
NoCellsSelected:
       Resume Next
       On Error GoTo 0
    Next iCntr
    
    Application.DisplayAlerts = False
    oNewWkBk.Sheets("Sheet1").Delete
    Application.DisplayAlerts = True
  
End Sub

[snasui]

สวัสดีครับ อาจารย์ มีเรื่องให้ช่วยเหลือครับ

งดระบุผู้ตอบครับ

[godman]

รับทราบครับ ต่อไปจะปฏิบัติครับ

[snasui]

ทำการ Assign ค่าให้กับ Array ให้ครบครับ ตัวอย่างตามด้านล่าง

Code: Select all

    zSheets(0) = "Add_New"
    zSheets(1) = "Sheet1"
    zSheets(2) = "Sheet2"
    zSheets(3) = "Sheet3"
    zSheets(4) = "Sheet4"

กรณีไม่มีชีทนั้นอยู่จริงจะเกิดค่าผิดพลาดครับ

[godman]

ผมทดลองลบให้เหลือชี้ตเดียว ชื่อ home ก็ยังขึ้น error แบบเดิมครับ
และคำถามต่อมา จาก code ดังกล่าว สามารถปรับเปลี่ยนว่าให้เลือกชี้ตใดชี้ตหนึ่งไปเป็น new workbook ได้ไหมครับ จะต้องปรับ code อย่่างไร

[snasui]

ปรับให้เหลือชีทเดียวก็ไม่ต้อง Loop ครับ ดูตัวอย่างการปรับ Code ตามด้านล่างครับ

Code: Select all

Sub SheetsToNewWorkbook()

   Dim oBaseWkBk    As Workbook
   Dim oNewWkBk     As Workbook
   Dim zSheets(5)   As String
   Dim zNewFileName As String
   Dim iCntr        As Integer
   
   zSheets(0) = "Home"
   
    
    Set oBaseWkBk = ActiveWorkbook
    Sheets("Home").Select
    zNewFileName = [C6].Value & Format([F7].Value) & ".xls"
    Set oNewWkBk = Workbooks.Add
    Application.DisplayAlerts = False
    oNewWkBk.SaveAs Filename:=zNewFileName, _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    Application.DisplayAlerts = True
    
    
'    For iCntr = 0 To UBound(zSheets) - 1
       oBaseWkBk.Activate
       Sheets(zSheets(0)).Copy Before:=Workbooks(oNewWkBk.Name).Sheets("Sheet1")
       On Error GoTo NoCellsSelected
       Selection.SpecialCells(xlCellTypeFormulas, 23).Select
       With Selection
           .Copy
           .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
                  SkipBlanks:=False, Transpose:=False
       End With  'Selection
       Application.CutCopyMode = False
NoCellsSelected:
       Resume Next
       On Error GoTo 0
'    Next iCntr
    
    Application.DisplayAlerts = False
    oNewWkBk.Sheets("Sheet1").Delete
    Application.DisplayAlerts = True
  
End Sub

จาก code ดังกล่าว สามารถปรับเปลี่ยนว่าให้เลือกชี้ตใดชี้ตหนึ่งไปเป็น new workbook ได้ไหมครับ จะต้องปรับ code อย่่างไร

สามารถปรับได้ครับ ปรับมาเองก่อน ติดตรงไหนค่อยถามมาครับ