จะทำการ copy sheet เปลี่ยนชื่อตามข้อมูลครับ แต่แสดงไม่ตรงครับรบกวนด้วยครับ

[preseed]

สวัสดีครับ ผมอยากจะรบกวนช่วยดู code ที่ผมต้องการคือ

ในไฟล์งาน คอลัมน์ E จะเป็นตัวรหัสโดยที่ พอรันmacro แล้วจะให้นำรหัสไปใส่ในช่อง B4 ของ Sheet Temp
แล้วทำการcopy Sheet Temp ไปต่อท้าย แล้วเปลี่ยนชื่อไปตามรหัส ของช่องB4ในSheetTemp
แล้วทำวนไปจนสุดข้อมูลใน คอลัมน์ E ครับ

แต่ติดปัญหาว่า มีการแสดงผลไม่ตรงมีการกระโดดข้ามของข้อมูล รบกวนช่วยดูและแนะนำทีครับ


ขอบคุณครับ

Code ครับ

Code: Select all

Sub test()
    Dim i As Long
    Dim r As Range
       On Error Resume Next
    With Worksheets("Data")
        Set r = .Range("E2", .Range("E65536").End(xlUp))
    End With
    For i = 1 To r.Count
        
        If i > 1 Then
        Sheets("Data").Select
        Cells((2 + i), 5).Select
        Selection.Copy
        Sheets("Temp").Select
        Range("B4").Select
        ActiveSheet.Paste
        Sheets("Temp").Select
        Sheets("Temp").Copy After:=Sheets(2)
        ActiveSheet.Name = Range("B4")
        Sheets("Data").Select
        
        End If
        
        Sheets("Data").Select
        Range("E2").Select
        Selection.Copy
        Sheets("Temp").Select
        Range("B4").Select
        ActiveSheet.Paste
        Sheets("Temp").Select
        Sheets("Temp").Copy After:=Sheets(2)
        ActiveSheet.Name = Range("B4")
        Sheets("Data").Select
        

    Next i
End Sub

[snasui]

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

Code: Select all

Dim rall As Range
Dim r As Range
With Sheets("Data")
    Set rall = .Range("e2", .Range("e" & .Rows.Count).End(xlUp))
    For Each r In rall
        Sheets("Temp").Range("b4").Value = r.Value
        Sheets("Temp").Copy after:=Sheets("Temp")
    Next r
End With

[preseed]

ขอบคุณครับ

[preseed]

ขอรบกวนสอบถามต่อจากด้านบนครับ

คือตอนนี้ผมต้องการจะแยกsheet ที่ได้รันมา แยกเป็นไฟล์ PDF แต่ละไฟล์ โดยชื่อเป็นไปตามชื่อsheet
และทำการsave ไปในfolder โดยให้สร้าง folder ตามชื่อ sheet ด้วยครับ

เช่น ชื่อsheet ในไฟล์เป็น 1 ให้สร้าง folder ชื่อ 1 และsaveไฟล์ เป็น 1.pdf แล้วไปใส่ใน folder 1ครับ ประมาณ D:\1\1.pdf แบบนี้ครับ

ผมลองเขียนแล้วตันเลยมาขอความช่วยเหลือครับ

Code: Select all

Sub á¡data()
Dim rall As Range
Dim r As Range
With Sheets("Data")
    Set rall = .Range("o2", .Range("o" & .Rows.Count).End(xlUp))
    For Each r In rall
        Sheets("Temp").Range("b4").Value = r.Value
        Sheets("Temp").Copy after:=Sheets("Temp")
        ActiveSheet.Name = Range("B4")
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        "D:\ตามค่า B4\ตามค่า B4.pdf", Quality:= _
        xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    Next r
End With
End Sub

ขอบคุณครับ

[snasui]

แนบไฟล์ที่ได้เขียน Code ล่าสุดแล้วมาด้วยจะได้ช่วยดูต่อไปจากนั้นครับ

[preseed]

แนบไฟล์ที่ได้เขียน Code ล่าสุดแล้วมาด้วยจะได้ช่วยดูต่อไปจากนั้นครับ

รบกวนด้วยครับ

ขอบคุณครับ

[snasui]

ไม่พบ Code ด้านบนในไฟล์ที่แนบมา สำหรับการสร้าง Folder ศึกษาจาก Link นี้ viewtopic.php?t=132 ลองเขียนมาเองดูก่อนติดตรงไหนค่อยถามกันต่อครับ

[preseed]

ได้แล้วครับบบบ ขอบคุณครับ น้ำตาไหลเลย พอดีเป็นมือใหม่หัดเริ่ม
ผมแก้ได้เป็นตามนี้ครับ

Code: Select all

Option Explicit
Function FolderExist(Path As String) As Boolean
    On Error Resume Next
    If Not Dir(Path, vbDirectory) = vbNullString Then
        FolderExist = True
    End If
    On Error GoTo 0
End Function
Sub á¡pdf()
Dim i As Integer
For i = 3 To ThisWorkbook.Worksheets.Count
    If FolderExist("D:\Test\" & ThisWorkbook.Worksheets(i).Range("B4").Value & "") Then
        ChDir "D:\Test\" & Range("B4").Value & ""
ThisWorkbook.Worksheets(i).Copy
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"D:\Test\" & ThisWorkbook.Worksheets(i).Range("B4").Value & "\" & Range("B4").Value & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
ActiveWorkbook.Close False
   Else
    On Error Resume Next
        MkDir "D:\Test\"
        MkDir "D:\Test\" & ThisWorkbook.Worksheets(i).Range("B4").Value & ""
        ChDir "D:\Test\" & ThisWorkbook.Worksheets(i).Range("B4").Value & ""
        ThisWorkbook.Worksheets(i).Copy
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    "D:\Test\" & ThisWorkbook.Worksheets(i).Range("B4").Value & "\" & Range("B4").Value & ".pdf", Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
ActiveWorkbook.Close False
    End If
Next i
End Sub

ผมรบกวนถามเพิ่มครับ คือตอนนี้ถ้าผมรัน code

Code: Select all

Sub á¡data()
Dim rall As Range
Dim r As Range
With Sheets("Data")
    Set rall = .Range("o2", .Range("o" & .Rows.Count).End(xlUp))
    For Each r In rall
        Sheets("Temp").Range("b4").Value = r.Value
        Sheets("Temp").Copy after:=Sheets("Temp")
        ActiveSheet.Name = Range("B4")
    Next r
End With
End Sub

เวลาทำงานจะแยกรหัสออกมาจาก form temp worksheet จะเยอะมากๆ แล้ว ผมจึ่งรัน code PDFต่อ คือปลายทางผมอยากได้ แค่ไฟล์ PDF ผมสามารถรวม code ได้เลยไหมครับ

ปล.แก้ไข แนบไฟล์เพิ่มครับ

[snasui]

ตัวอย่างการเรียกใช้ Code อืนภายใน Code ใด Code หนึ่งครับ

Code: Select all

Sub แยกdata()
Dim rall As Range
Dim r As Range
With Sheets("Data")
    Set rall = .Range("o2", .Range("o" & .Rows.Count).End(xlUp))
    For Each r In rall
        Sheets("Temp").Range("b4").Value = r.Value
        Sheets("Temp").Copy after:=Sheets("Temp")
        ActiveSheet.Name = Range("B4")
    Next r
End With
Call Module3.แยกpdf
End Sub

[preseed]

ตัวอย่างการเรียกใช้ Code อืนภายใน Code ใด Code หนึ่งครับ

Code: Select all

Sub แยกdata()
Dim rall As Range
Dim r As Range
With Sheets("Data")
    Set rall = .Range("o2", .Range("o" & .Rows.Count).End(xlUp))
    For Each r In rall
        Sheets("Temp").Range("b4").Value = r.Value
        Sheets("Temp").Copy after:=Sheets("Temp")
        ActiveSheet.Name = Range("B4")
    Next r
End With
Call Module3.แยกpdf
End Sub

ขอบคุณครับ อยากจะรบกวนถามอีก 1 อย่างครับ

ตอนนี้ผมแยกไฟล์ ออกมาเป็น pdf แล้วถ้า ผมอยากเปลี่ยนมาsave เป็น .jpg ได้ไหมครับ

[snasui]

การใช้ VBA จำเป็นต้องเขียนมาเองก่อนเสมอ ติดแล้วค่อยถามกันต่อ ลองศึกษาจาก Link นี้เป็นแนวทางครับ Save As JPG