Excel Forum

Code: Select all

Sub Button28_PDF()

Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
Dim codebranch As String
Dim branchname As String
Dim lictype As String
On Error GoTo errHandler


If InStr(Range("b5").value, "นายหน้า") > 0 Then
    lictype = "นายหน้า"
ElseIf InStr(Range("b5").value, "ตัวแทน") > 0 Then
    lictype = "ตัวแทน"
ElseIf InStr(Range("b5").value, "ร่วมใบอนุญาต") > 0 Then
    lictype = "ร่วมใบอนุญาต"
End If

codebranch = Left(Range("A1"), 3)
branchname = Mid(Range("A1"), 7, 50)
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "dd_mm_yy")

'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
  strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"

'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")

'create default name for savng file
strFile = lictype & "_" & codebranch & "_" & branchname & "_" & strTime & ".pdf"
strPathFile = strPath & strFile

'use can enter name and
' select folder for file
myFile = Application.GetSaveAsFilename _
    (InitialFileName:=strPathFile, _
        FileFilter:="PDF Files (*.pdf), *.pdf", _
        Title:="Select Folder and FileName to save")

'export to PDF if a folder was selected
If myFile <> "False" Then
    wsA.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=myFile, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    'confirmation message with file info
    MsgBox "PDF file has been created: " _
      & vbCrLf _
      & myFile
End If

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not create PDF file"
    Resume exitHandler
End Sub

Code: Select all

Sub Button28_PDF()

Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
Dim codebranch As String
Dim branchname As String
Dim lictype As String
Dim shp As Shape
On Error GoTo errHandler


If InStr(Range("b5").value, "¹ÒÂ˹éÒ") > 0 Then
    lictype = "¹ÒÂ˹éÒ"
ElseIf InStr(Range("b5").value, "µÑÇá·¹") > 0 Then
    lictype = "µÑÇá·¹"
ElseIf InStr(Range("b5").value, "ÃèÇÁãºÍ¹Ø­Òµ") > 0 Then
    lictype = "ÃèÇÁãºÍ¹Ø­Òµ"
End If

codebranch = VBA.Left(Range("A1"), 3)
branchname = VBA.Mid(Range("A1"), 7, 50)
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = VBA.Format(Now(), "dd_mm_yy")

'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
  strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"

'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")

'create default name for savng file
strFile = lictype & "_" & codebranch & "_" & branchname & "_" & strTime & ".xlsx"
strPathFile = strPath & strFile

'use can enter name and
' select folder for file
myFile = Application.GetSaveAsFilename _
    (InitialFileName:=strPathFile, _
        FileFilter:="Excel Files (*.xls*), *.xls*", _
        Title:="Select Folder and FileName to save")

'export to PDF if a folder was selected
'If myFile <> "False" Then
'    wsA.ExportAsFixedFormat _
'        Type:=xltyp, _
'        Filename:=myFile, _
'        Quality:=xlQualityStandard, _
'        IncludeDocProperties:=True, _
'        IgnorePrintAreas:=False, _
'        OpenAfterPublish:=False

ActiveSheet.Copy
For Each shp In ActiveSheet.Shapes
    shp.Delete
Next shp
ActiveSheet.Range("a1:a3").EntireRow.Delete
ActiveWorkbook.SaveAs myFile
ActiveWorkbook.Close False
    'confirmation message with file info
    MsgBox "Excel file has been created: " _
      & vbCrLf _
      & myFile
'End If

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not create Excel file with the same name."
    Resume exitHandler
End Sub

Code: Select all

Sub Button29_EXCEL()

Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
Dim codebranch As String
Dim branchname As String
Dim lictype As String
On Error GoTo errHandler


If InStr(Range("b5").value, "นายหน้า") > 0 Then
    lictype = "นายหน้า"
ElseIf InStr(Range("b5").value, "ตัวแทน") > 0 Then
    lictype = "ตัวแทน"
ElseIf InStr(Range("b5").value, "ร่วมใบอนุญาต") > 0 Then
    lictype = "ร่วมใบอนุญาต"
End If

codebranch = Left(Range("A1"), 3)
branchname = Mid(Range("A1"), 7, 50)
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "dd_mm_yy")

'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
  strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"

'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")

'create default name for savng file
strFile = lictype & "_" & codebranch & "_" & branchname & "_" & strTime & ".pdf"
strPathFile = strPath & strFile

'use can enter name and
' select folder for file
'myFile = Application.GetSaveAsFilename _
    '(InitialFileName:=strPathFile, _
        'FileFilter:="PDF Files (*.pdf), *.pdf", _
        'Title:="Select Folder and FileName to save")

If Val(Application.Version) < 9 Then Exit Sub
    If Val(Application.Version) < 12 Then

        'Only choice in the "Save as type" dropdown is Excel files(xls)
        'because the Excel version is 2000-2003
        fname = Application.GetSaveAsFilename(InitialFileName:=lictype & "_" & codebranch & "_" & branchname & "_" & strTime, _
        filefilter:="Excel Files (*.xls), *.xls", _
        Title:="This example copies the ActiveSheet to a new workbook")

        If fname <> False Then
            'Copy the ActiveSheet to new workbook
            For Each wsA In ActiveWorkbook.Worksheets
                    wsA.UsedRange.Copy
                    wsA.UsedRange.PasteSpecial Paste:=xlPasteValues
            Application.CutCopyMode = False
   Next
                Set NewWb = ActiveWorkbook
                     Rows("1:3").Select
                     Selection.Delete Shift:=xlUp
            'We use the 2000-2003 format xlWorkbookNormal here to save as xls
            NewWb.SaveAs fname, FileFormat:=-4143, CreateBackup:=False
            NewWb.Close False
            Set NewWb = Nothing

        End If
    Else
        'Give the user the choice to save in 2000-2003 format or in one of the
        'new formats. Use the "Save as type" dropdown to make a choice,Default =
        'Excel Macro Enabled Workbook. You can add or remove formats to/from the list
        
        fname = Application.GetSaveAsFilename(InitialFileName:=lictype & "_" & codebranch & "_" & branchname & "_" & strTime, filefilter:= _
            " Excel Macro Free Workbook (*.xlsx), *.xlsx," & _
            " Excel Macro Enabled Workbook (*.xlsm), *.xlsm," & _
            " Excel 2000-2003 Workbook (*.xls), *.xls," & _
            " Excel Binary Workbook (*.xlsb), *.xlsb", _
            FilterIndex:=2, Title:="This example copies the ActiveSheet to a new workbook")

        'Find the correct FileFormat that match the choice in the "Save as type" list
        If fname <> False Then
            Select Case LCase(Right(fname, Len(fname) - InStrRev(fname, ".", , 1)))
            Case "xls": FileFormatValue = 56
            Case "xlsx": FileFormatValue = 51
            Case "xlsm": FileFormatValue = 52
            Case "xlsb": FileFormatValue = 50
            Case Else: FileFormatValue = 0
            End Select

            'Now we can create/Save the file with the xlFileFormat parameter
            'value that match the file extension
            If FileFormatValue = 0 Then
                MsgBox "Sorry, unknown file extension"
            Else
                'Copies the ActiveSheet to new workbook
                ActiveSheet.Copy
                For Each wsA In ActiveWorkbook.Worksheets
                    wsA.UsedRange.Copy
                    wsA.UsedRange.PasteSpecial Paste:=xlPasteValues
         Application.CutCopyMode = False
   Next
                Set NewWb = ActiveWorkbook
                     Rows("1:3").Select
                     Selection.Delete Shift:=xlUp
                'Save the file in the format you choose in the "Save as type" dropdown
                NewWb.SaveAs fname, FileFormat:= _
                             FileFormatValue, CreateBackup:=False
                NewWb.Close False
                Set NewWb = Nothing

            End If
        End If
    End If
'End If

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not create PDF file"
    Resume exitHandler
End Sub

Code: Select all

 fname = Application.GetSaveAsFilename(InitialFileName:=lictype & "_" & codebranch & "_" & branchname & "_" & strTime,

Code: Select all

'create default name for savng file
strFile = lictype & "_" & codebranch & "_" & branchname & "_" & strTime & ".pdf"
strPathFile = strPath & strFile

'use can enter name and
' select folder for file
'myFile = Application.GetSaveAsFilename _
    '(InitialFileName:=strPathFile, _
        'FileFilter:="PDF Files (*.pdf), *.pdf", _
        'Title:="Select Folder and FileName to save")

If Val(Application.Version) < 9 Then Exit Sub
    If Val(Application.Version) < 12 Then

        'Only choice in the "Save as type" dropdown is Excel files(xls)
        'because the Excel version is 2000-2003
        fname = Application.GetSaveAsFilename(InitialFileName:=lictype & "_" & codebranch & "_" & branchname & "_" & strTime, _
        filefilter:="Excel Files (*.xls), *.xls", _
        Title:="This example copies the ActiveSheet to a new workbook")

Code: Select all

Sub Button29_EXCEL()

Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
Dim codebranch As String
Dim branchname As String
Dim lictype As String
On Error GoTo errHandler


If InStr(Range("b5").value, "นายหน้า") > 0 Then
    lictype = "นายหน้า"
ElseIf InStr(Range("b5").value, "ตัวแทน") > 0 Then
    lictype = "ตัวแทน"
ElseIf InStr(Range("b5").value, "ร่วมใบอนุญาต") > 0 Then
    lictype = "ร่วมใบอนุญาต"
End If

codebranch = Left(Range("A1"), 3)
branchname = Mid(Range("A1"), 7, 50)
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "dd_mm_yy")

'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
  strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"

'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")

'create default name for savng file
strFile = lictype & "_" & codebranch & "_" & branchname & "_" & strTime & ".pdf"
strPathFile = strPath & strFile

'use can enter name and
' select folder for file
'myFile = Application.GetSaveAsFilename _
    '(InitialFileName:=strPathFile, _
        'FileFilter:="PDF Files (*.pdf), *.pdf", _
        'Title:="Select Folder and FileName to save")

If Val(Application.Version) < 9 Then Exit Sub
    If Val(Application.Version) < 12 Then

        'Only choice in the "Save as type" dropdown is Excel files(xls)
        'because the Excel version is 2000-2003
        fname = Application.GetSaveAsFilename(InitialFileName:=lictype & "_" & codebranch & "_" & branchname & "_" & strTime, _
        filefilter:="Excel Files (*.xls), *.xls", _
        Title:="This example copies the ActiveSheet to a new workbook")

        If fname <> False Then
            'Copy the ActiveSheet to new workbook
            For Each wsA In ActiveWorkbook.Worksheets
                    wsA.UsedRange.Copy
                    wsA.UsedRange.PasteSpecial Paste:=xlPasteValues
            Application.CutCopyMode = False
   Next
                Set NewWb = ActiveWorkbook
                     Rows("1:3").Select
                     Selection.Delete Shift:=xlUp
            'We use the 2000-2003 format xlWorkbookNormal here to save as xls
            NewWb.SaveAs fname, FileFormat:=-4143, CreateBackup:=False
            NewWb.Close False
            Set NewWb = Nothing

        End If
    Else
        'Give the user the choice to save in 2000-2003 format or in one of the
        'new formats. Use the "Save as type" dropdown to make a choice,Default =
        'Excel Macro Enabled Workbook. You can add or remove formats to/from the list
        
        fname = Application.GetSaveAsFilename(InitialFileName:=lictype & "_" & codebranch & "_" & branchname & "_" & strTime, filefilter:= _
            " Excel Macro Free Workbook (*.xlsx), *.xlsx," & _
            " Excel Macro Enabled Workbook (*.xlsm), *.xlsm," & _
            " Excel 2000-2003 Workbook (*.xls), *.xls," & _
            " Excel Binary Workbook (*.xlsb), *.xlsb", _
            FilterIndex:=2, Title:="This example copies the ActiveSheet to a new workbook")

        'Find the correct FileFormat that match the choice in the "Save as type" list
        If fname <> False Then
            Select Case LCase(Right(fname, Len(fname) - InStrRev(fname, ".", , 1)))
            Case "xls": FileFormatValue = 56
            Case "xlsx": FileFormatValue = 51
            Case "xlsm": FileFormatValue = 52
            Case "xlsb": FileFormatValue = 50
            Case Else: FileFormatValue = 0
            End Select

            'Now we can create/Save the file with the xlFileFormat parameter
            'value that match the file extension
            If FileFormatValue = 0 Then
                MsgBox "Sorry, unknown file extension"
            Else
                'Copies the ActiveSheet to new workbook
                ActiveSheet.Copy
                For Each wsA In ActiveWorkbook.Worksheets
                    wsA.UsedRange.Copy

Code: Select all

MsgBox "Could not create PDF file"
    Resume exitHandler
End Sub

Code: Select all

'...Other code
            If FileFormatValue = 0 Then
                MsgBox "Sorry, unknown file extension"
            Else
                'Copies the ActiveSheet to new workbook
                ActiveSheet.Range("A1").UnMerge
                ActiveSheet.Range("B4").UnMerge
                ActiveSheet.Range("B5").UnMerge
                Application.Calculation = xlCalculationManual
                ActiveSheet.Copy
                Dim r As Range
                For Each wsA In ActiveWorkbook.Worksheets
                    For Each r In wsA.ListObjects(1).Range
                        r.value = r.value
                    Next r
                Next wsA
                Application.Calculation = xlCalculationAutomatic
                Set NewWb = ActiveWorkbook
                Rows("1:3").Select
                Selection.Delete Shift:=xlUp
                For i = 1 To 2
                   Range(Cells(i, 2), Cells(i, 14)).MergeCells = True
                Next i
                'Save the file in the format you choose in the "Save as type" dropdown
                NewWb.SaveAs fname, FileFormat:= _
                             FileFormatValue, CreateBackup:=False
                NewWb.Close False
                Set NewWb = Nothing
                Range("A1:C1").Merge
                Range("B4:N4").Merge
                Range("B5:N5").Merge
            End If
'...Other code