Excel Forum

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

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

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

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: 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

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