รบกวนแก้ code vba save file to pdf

[Jancha]

ถามปัญหา Module4 ที่ Sub SavePDF จะให้ทำการ convert sheet to pdf ตั้งแต่ sheet 2 ถึง sheet สุดท้าย ตอนนี้ติดตรงชื่อที่ปรากฎขึ้นให้ save file ไม่ตรงกับ sheet ที่ทำการ convert pdf โดยที่ชื่อที่ต้องการให้ทำการ save นั้นเกิดมาจากนำ cell B4 ของแต่ละ sheet มาต่อด้วยข้อความว่า "_Jan_2019" โดยไม่ต้องมาพิมพ์ทุกครั้งก่อนกด save ครับ รบกวนแก้ไข code ให้ด้วยครับ ขอบคุณ

Code: Select all

Sub SavePDF()
'
'
Dim name1 As String
Dim fileName As String
Dim filepath As String

    Dim shs() As Variant                        
    Dim i As Integer, j As Integer            
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False

strpath = ActiveWorkbook.Path
filepath = strpath & "\"

name1 = Range("B4").Value & "_Jan_2019"

    For i = 2 To Sheets.Count              
        ReDim Preserve shs(j)               
        shs(j) = Worksheets(i).name      

fileName = Application.GetSaveAsFilename(filepath & name1 & name2 & name3, _
                                         FileFilter:="PDF Files (*.pdf), *.pdf", _
                                         Title:="Select Path and FileName to save")


    If fileName <> "False" Then

        With ActiveWorkbook

                .Worksheets(i).ExportAsFixedFormat Type:=xlTypePDF, fileName:= _
                    fileName, Quality:=xlQualityStandard, _
                    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

        End With

    End If
                                
            j = j + 1    
    Next i               
                                
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

[snasui]

ตัวอย่างการปรับ Code ครับ

Code: Select all

'Other code
    For i = 2 To Sheets.Count              
        ReDim Preserve shs(j)               
        shs(j) = Worksheets(i).name
        name1 = Worksheets(i).Range("B3").Value & "_Jan_2019"
'Other code

ควรสอบถามมาพร้อมไฟล์ Excel ที่เขียน Code นี้ไว้แล้ว จะได้สะดวกต่อเพื่อนสมาชิกในการตอบปัญหาครับ

[Jancha]

ขออภัยครับไม่คิดว่าจะได้คำตอบเร็วขนาดนี้ พอดีลงข้อมูลผิดจึงแก้กระทู้และมีการลบ attach file ตอนนี้ทำการแนบมาพร้อม code ที่อาจารย์ช่วยปรับให้แล้วครับ ได้คำตอบตามต้องการ ขอบคุณมากนะครับ

Code: Select all

Sub SavePDF()
'
'
Dim name1 As String
Dim fileName As String
Dim filepath As String

    Dim shs() As Variant                        
    Dim i As Integer, j As Integer            
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False

strpath = ActiveWorkbook.Path
filepath = strpath & "\"

    For i = 2 To Sheets.Count              
        ReDim Preserve shs(j)               
        shs(j) = Worksheets(i).name      
        name1 = Worksheets(i).Range("B4").Value & "_Jan_2019"

fileName = Application.GetSaveAsFilename(filepath & name1 & name2 & name3, _
                                         FileFilter:="PDF Files (*.pdf), *.pdf", _
                                         Title:="Select Path and FileName to save")


    If fileName <> "False" Then

        With ActiveWorkbook

                .Worksheets(i).ExportAsFixedFormat Type:=xlTypePDF, fileName:= _
                    fileName, Quality:=xlQualityStandard, _
                    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False 

        End With

    End If
                                
            j = j + 1     
    Next i                
                                
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

[Jancha]

รบกวนแก้ code ที่ Module 2 ตรง Sub RTP ครับ หลักการทำงานของ code นี้คือให้เลือก range ข้อมูลของแต่ละ sheet ตั้งแต่ sheet 2 ไปจน sheet สุดท้ายและทำการ save range ที่เลือกเหล่านั้นออกไปเป็นรูปภาพ(.gif, .jpg, .png) เก็บไว้ที่เดียวกับไฟล์ต้นฉบับ ตอนนี้ทำได้ถึงเลือก range แบบเจาะจงลงไปครับ ถ้าข้อมูลในแต่ละ sheet ต่างกันไป จะไม่ support และยืดหยุ่นกับงานครับ รบกวนด้วยครับ ขอบคุณ

Code: Select all

Sub RTP()

 Dim Ws As Worksheet
 Dim Rng As Range
 Dim Chrt As ChartObject
 Dim lWidth As Long, lHeight As Long
 Dim i As Integer
 
        For i = 2 To Sheets.Count
        Sheets(i).Select

                     Set Ws = ActiveSheet
                     Set Rng = Ws.Range("B3:O12")        ''' range to picture
                     '       Range("B3").Select
                     '       Range(Selection, Selection.End(xlDown)).Select
                     '       Range(Selection, Selection.End(xlToRight)).Select
                     ExportPath = ThisWorkbook.Path & "\" & Range("C4").Value & ".png"      '"\img.png"
                     
                     Rng.CopyPicture xlScreen, xlPicture
                     lWidth = Rng.Width
                     lHeight = Rng.Height
                    
                     Set Chrt = Ws.ChartObjects.Add(Left:=0, Top:=0, Width:=lWidth, Height:=lHeight)
                    
                     Chrt.Activate
                     With Chrt.Chart
                      .Paste
                      .Export fileName:=ExportPath, Filtername:="PNG"
                     End With
                     Chrt.Delete

        Next i
    Sheets("Assessment").Select
End Sub

[snasui]

ตัวอย่าง Code ครับ

Code: Select all

'Other code
For i = 2 To Sheets.Count
    With Sheets(i)
        'Set Ws = ActiveSheet
        Set Rng = .Range("B3", .Range("B" & .Rows.Count).End(xlUp)) _
            .Resize(, 14)
        '       Range("B3").Select
        '       Range(Selection, Selection.End(xlDown)).Select
        '       Range(Selection, Selection.End(xlToRight)).Select
        ExportPath = ThisWorkbook.Path & "\" & Range("C4").Value & ".png"      '"\img.png"
        
        Rng.CopyPicture xlScreen, xlPicture
        lWidth = Rng.Width
        lHeight = Rng.Height
        
        Set Chrt = Ws.ChartObjects.Add(Left:=0, Top:=0, Width:=lWidth, Height:=lHeight)
        
        Chrt.Activate
        With Chrt.Chart
            .Paste
            .Export fileName:=ExportPath, Filtername:="PNG"
        End With
        Chrt.Delete
    End With
Next i
'Other code

[Jancha]

ทำการ run code ข้างต้นยังไม่ผ่านครับ

[snasui]

ปรับ Code ที่บรรทัด Set Chrt = Ws.ChartObjects.Add(Left:=0, Top:=0, Width:=lWidth, Height:=lHeight) เป็น

Set Chrt = .ChartObjects.Add(Left:=0, Top:=0, Width:=lWidth, Height:=lHeight) ครับ

[Jancha]

ขอบคุณมากครับอาจารย์ผมเพิ่มบรรทัดนี้ Sheets(i).Select เพื่อได้ชื่อที่ save ตรงกับชื่อของ Employee ของ sheet นั้นๆครับที่เหลือได้ตามต้องการเลยครับ

Code: Select all

Sub RTB()

 Dim Rng As Range
 Dim Chrt As ChartObject
 Dim lWidth As Long, lHeight As Long
 Dim i As Integer

For i = 2 To Sheets.Count
    With Sheets(i)
                Sheets(i).Select
                Set Rng = .Range("B3", .Range("B" & .Rows.Count).End(xlUp)) _
                    .Resize(, 14)
        
                ExportPath = ThisWorkbook.Path & "\" & Range("C4").Value & ".png"
                
                Rng.CopyPicture xlScreen, xlPicture
                lWidth = Rng.Width
                lHeight = Rng.Height
                
                Set Chrt = .ChartObjects.Add(Left:=0, Top:=0, Width:=lWidth, Height:=lHeight)
                
                Chrt.Activate
                With Chrt.Chart
                    .Paste
                    .Export fileName:=ExportPath, Filtername:="PNG"
                End With
                Chrt.Delete
            End With
        Next i

    Sheets("Assessment").Select
End Sub

[snasui]

สามารถเปลี่ยน ExportPath = ThisWorkbook.Path & "\" & Range("C4").Value & ".png" เป็น ExportPath = ThisWorkbook.Path & "\" & .Range("C4").Value & ".png" แทนเพิ่มการ Select ครับ

[Jancha]

ได้เหมือนกัน เยี่ยมเลยครับ