Snasui Excel Forum

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 á¡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.Move
        
        If FolderExist("D:\Test\" & ActiveSheet.Range("B4").Value & "") Then
        ChDir "D:\Test\" & Range("B4").Value & ""
ThisWorkbook.Copy
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"D:\Test\" & ActiveSheet.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\" & ActiveSheet.Range("B4").Value & ""
        ChDir "D:\Test\" & ActiveSheet.Range("B4").Value & ""
        ThisWorkbook.Copy
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    "D:\Test\" & ActiveSheet.Range("B4").Value & "\" & Range("B4").Value & ".pdf", Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
ActiveWorkbook.Close False
    End If
    Next r
End With
End Sub

Code: Select all

Sub á¡data()
    Dim rall As Range, r As Range
    Application.DisplayAlerts = False
    With Sheets("Data")
        Set rall = .Range("o2", .Range("o" & .Rows.Count).End(xlUp))
    End With
    For Each r In rall
        With Sheets("Temp")
            .Range("b4").Value = r.Value
            .Copy after:=Sheets("Temp")
        End With
        With ActiveSheet
            .Name = .Range("b4").Value
            If FolderExist("D:\Test\" & .Name) Then
                ChDir "D:\Test\" & .Name
                .ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
                "D:\Test\" & .Name & "\" & _
                    .Name & ".pdf", Quality:=xlQualityStandard, _
                    IncludeDocProperties:=True, IgnorePrintAreas:=False, _
                    OpenAfterPublish:=False
            Else
                On Error Resume Next
                MkDir "D:\Test\"
                MkDir "D:\Test\" & .Name
                ChDir "D:\Test\" & .Name
                .ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
                "D:\Test\" & .Name & "\" & _
                    .Name & ".pdf", Quality:=xlQualityStandard, _
                    IncludeDocProperties:=True, IgnorePrintAreas:=False, _
                    OpenAfterPublish:=False
            End If
            .Delete
        End With
    Next r
    Application.DisplayAlerts = True
End Sub