Tag Archives: vba

Excel visual basic (vba) resize and export all charts to png file

Excel visual basic (vba) resize and export all charts to png file

Sub LineUpMyCharts()

    Dim MyWidth As Single, MyHeight As Single

    Dim NumWide As Long

    Dim iChtIx As Long, iChtCt As Long

    MyWidth = 375

    MyHeight = 250

    NumWide = 2

    iChtCt = ActiveSheet.ChartObjects.Count

    For iChtIx = 1 To iChtCt

        With ActiveSheet.ChartObjects(iChtIx)

            .Width = MyWidth

            .Height = MyHeight

            .Left = ((iChtIx – 1) Mod NumWide) * MyWidth

            .Top = Int((iChtIx – 1) / NumWide) * MyHeight

        End With

        pngName = ActiveWorkbook.Path & "\png\" & iChtIx & ".png"

        ActiveSheet.ChartObjects(iChtIx).Activate

        ActiveChart.Export FileName:=pngName, FilterName:="PNG"

    Next

End Sub

Comments ( 0 )

Simple Excel sprintf visual basic (vba) macro

Simple Excel sprintf visual basic (vba) macro.

Example:  "=printf("Some text '%s', more text: '%s'", A1, A2)"

Public Function Printf(mask As String, ParamArray tokens()) As String

    Dim i As Long

     For i = 0 To UBound(tokens)

          mask = Replace$(mask, "%s", tokens(i), , 1)

     Next

     Printf = mask

End Function

See http://stackoverflow.com/questions/17233701/is-there-an-equivalent-of-printf-or-string-format-in-excel and http://www.freevbcode.com/ShowCode.asp?ID=5014 for an more elaborate implementation.

Comments ( 0 )

Excel visual basic (vba) macro to save a (selection) of a table to an utf-8 csv file

Excel vba macro to save a (selection) of a table to an utf-8 csv file

Public Sub ExportToCsv()

     Dim FName As String

     Dim Sep As String

     Dim Enclose As String

     Dim wsSheet As Worksheet

     Dim nFileNum As Integer

     Dim csvPath As String

     'Sep = InputBox("Enter a single delimiter character (e.g., comma or semi-colon)", "Export To Text File")

     Sep = ";"

     Enclose = """"

     'csvPath = InputBox("Enter the full path to export CSV files to: ")

     'csvPath = GetFolderName("Choose the folder to export CSV files to:")

     'If csvPath = "" Then

     '    MsgBox ("You didn't choose an export directory. Nothing will be exported.")

     '    Exit Sub

     'End If

     'For Each wsSheet In Worksheets

          'wsSheet.Activate

          Set wsSheet = ActiveSheet

          FName = ActiveWorkbook.Path & "\" & wsSheet.Name & ".csv"

          ExportToUTF8CsvFile FName, Sep, Enclose, True

     'Next wsSheet

End Sub

Public Sub ExportToUTF8CsvFile(FName As String, Sep As String, Enclose As String, SelectionOnly As Boolean)

    Dim WholeLine As String

    Dim RowNdx As Long

    Dim ColNdx As Integer

    Dim StartRow As Long

    Dim EndRow As Long

    Dim StartCol As Integer

    Dim EndCol As Integer

    Dim CellValue As String

    Dim fso, file, test

    Application.ScreenUpdating = False

    On Error GoTo EndMacro:

    If SelectionOnly = True Then

        With Selection

            StartRow = .Cells(1).Row

            StartCol = .Cells(1).Column

            EndRow = .Cells(.Cells.Count).Row

            EndCol = .Cells(.Cells.Count).Column

            If (StartRow – EndRow) = 0 And (StartCol – EndCol) = 0 Then

                SelectionOnly = False

            End If

        End With

    End If

    If SelectionOnly = False Then

        With ActiveSheet.UsedRange

            StartRow = .Cells(1).Row

            StartCol = .Cells(1).Column

            EndRow = .Cells(.Cells.Count).Row

            EndCol = .Cells(.Cells.Count).Column

        End With

    End If

    Set fso = CreateObject("ADODB.Stream")

    fso.Type = 2 'Specify stream type – we want To save text/string data.

    fso.Charset = "utf-8" 'Specify charset For the source text data.

    fso.Open 'Open the stream And write binary data To the object

    For RowNdx = StartRow To EndRow

        WholeLine = ""

        For ColNdx = StartCol To EndCol

            If Cells(RowNdx, ColNdx).Value = "" Then

                CellValue = ""

            Else

                CellValue = Cells(RowNdx, ColNdx).Value

            End If

            If CellValue = "(blank)" Then

                CellValue = ""

            End If

            CellValue = Enclose & CellValue & Enclose

            WholeLine = WholeLine & CellValue & Sep

        Next ColNdx

        WholeLine = Left(WholeLine, Len(WholeLine) – Len(Sep)) & vbCrLf

        fso.WriteText WholeLine

    Next RowNdx

    fso.SaveToFile FName, 2 'Save binary data To disk

    fso.Close

    MsgBox (RowNdx – 1) & " record(s) exported to " & FName

EndMacro:

    On Error GoTo 0

    Application.ScreenUpdating = True

End Sub

Based on http://stackoverflow.com/questions/59075/save-each-sheet-in-a-workbook-to-separate-csv-files and http://stackoverflow.com/questions/2524703/save-text-file-utf-8-encoded-with-vba

Comments ( 0 )

Excel visual basic (vba) resize and export all charts to png file

Excel visual basic (vba) resize and export all charts to png file

Sub LineUpMyCharts()

    Dim MyWidth As Single, MyHeight As Single
    Dim NumWide As Long
    Dim iChtIx As Long, iChtCt As Long

    MyWidth = 375
    MyHeight = 250
    NumWide = 2

    iChtCt = ActiveSheet.ChartObjects.Count

    For iChtIx = 1 To iChtCt
        With ActiveSheet.ChartObjects(iChtIx)
            .Width = MyWidth
            .Height = MyHeight
            .Left = ((iChtIx – 1) Mod NumWide) * MyWidth
            .Top = Int((iChtIx – 1) / NumWide) * MyHeight
        End With

        pngName = ActiveWorkbook.Path & “png” & iChtIx & “.png”
        ActiveSheet.ChartObjects(iChtIx).Activate
        ActiveChart.Export FileName:=pngName, FilterName:=”PNG”

    Next
End Sub
Comments ( 0 )

Excel visual basic (vba) macro to save a (selection) of a table to an utf-8 csv file

Excel vba macro to save a (selection) of a table to an utf-8 csv file


Public Sub ExportToCsv()
     Dim FName As String
     Dim Sep As String
     Dim Enclose As String
     Dim wsSheet As Worksheet
     Dim nFileNum As Integer
     Dim csvPath As String

     'Sep = InputBox(“Enter a single delimiter character (e.g., comma or semi-colon)”, “Export To Text File”)
     Sep = “;”
     Enclose = “”””
     'csvPath = InputBox(“Enter the full path to export CSV files to: “)

     'csvPath = GetFolderName(“Choose the folder to export CSV files to:”)
     'If csvPath = “” Then
     '    MsgBox (“You didn't choose an export directory. Nothing will be exported.”)
     '    Exit Sub
     'End If

     'For Each wsSheet In Worksheets
          'wsSheet.Activate
          Set wsSheet = ActiveSheet
          FName = ActiveWorkbook.Path & “” & wsSheet.Name & “.csv”
          ExportToUTF8CsvFile FName, Sep, Enclose, True
     'Next wsSheet

End Sub


Public Sub ExportToUTF8CsvFile(FName As String, Sep As String, Enclose As String, SelectionOnly As Boolean)

    Dim WholeLine As String
    Dim RowNdx As Long
    Dim ColNdx As Integer
    Dim StartRow As Long
    Dim EndRow As Long
    Dim StartCol As Integer
    Dim EndCol As Integer
    Dim CellValue As String
    Dim fso, file, test

    Application.ScreenUpdating = False
    On Error GoTo EndMacro:

    If SelectionOnly = True Then
        With Selection
            StartRow = .Cells(1).Row
            StartCol = .Cells(1).Column
            EndRow = .Cells(.Cells.Count).Row
            EndCol = .Cells(.Cells.Count).Column
            If (StartRow – EndRow) = 0 And (StartCol – EndCol) = 0 Then
                SelectionOnly = False
            End If
        End With
    End If

    If SelectionOnly = False Then
        With ActiveSheet.UsedRange
            StartRow = .Cells(1).Row
            StartCol = .Cells(1).Column
            EndRow = .Cells(.Cells.Count).Row
            EndCol = .Cells(.Cells.Count).Column
        End With
    End If


    Set fso = CreateObject(“ADODB.Stream”)
    fso.Type = 2 'Specify stream type – we want To save text/string data.
    fso.Charset = “utf-8” 'Specify charset For the source text data.
    fso.Open 'Open the stream And write binary data To the object

    For RowNdx = StartRow To EndRow
        WholeLine = “”

        For ColNdx = StartCol To EndCol
            If Cells(RowNdx, ColNdx).Value = “” Then
                CellValue = “”
            Else
                CellValue = Cells(RowNdx, ColNdx).Value
            End If

            If CellValue = “(blank)” Then
                CellValue = “”
            End If

            CellValue = Enclose & CellValue & Enclose

            WholeLine = WholeLine & CellValue & Sep
        Next ColNdx

        WholeLine = Left(WholeLine, Len(WholeLine) – Len(Sep)) & vbCrLf
        fso.WriteText WholeLine

    Next RowNdx

    fso.SaveToFile FName, 2 'Save binary data To disk

    fso.Close

    MsgBox (RowNdx – 1) & ” record(s) exported to ” & FName

EndMacro:
    On Error GoTo 0
    Application.ScreenUpdating = True

End Sub

Comments ( 0 )

Simple Excel sprintf visual basic (vba) macro

Simple Excel sprintf visual basic (vba) macro.
Example:  “=printf(“Some text '%s', more text: '%s'”, A1, A2)”

Public Function Printf(mask As String, ParamArray tokens()) As String
    Dim i As Long

     For i = 0 To UBound(tokens)
          mask = Replace$(mask, “%s”, tokens(i), , 1)
     Next

     Printf = mask

End Function
Comments ( 2 )