Tags » Vba

Shape Exporter: Export any Shape from any Stencil in Visio (2013) to PNG

The other day a customer told me he was “sick and tired” of people asking him to export shapes from Visio to a PNG file. 297 more words

Tools

VBA Conditional Formatting

A common request I get when writing code for others, is that they want something highlighted when certain criteria is entered.

You can of course use conditional formatting and even extend this beyond the target cell using formulated conditional formatting but there are restrictions on the number of criteria you can differentiate between. 530 more words

VBA

format change for characters in a cell

test

Option Explicit

Sub main1()
    Dim i As Integer
    For i = 2 To 3
        If Cells(i, 3) = "" Then
        Else
            Call search_and_fontstylechange(Cells(i, 3), Cells(i, 4))
        End If
    Next i
End Sub

'2003/11/30 指定した文字列を検索し、その文字だけに書式を設定する。
Function search_and_fontstylechange(ByVal str1 As String, ByVal color1 As Integer)
    
    Dim i As Long
    Dim tmpValue As Variant
    Dim response As Integer
    Dim tmpRange As Range
    Dim tmpCount As Long

    Dim search_char As String
    Dim search_char_len As Long
    Dim start_pos As Long

    Dim tmpColorIndex As Long
    Dim flgBold As Boolean
    Dim flgItalic As Boolean
    Dim tmpUnderLine As Variant
    Dim flgStrikethrough As Boolean
    Dim tmpFontStyle As String
    Dim arColorIndex As Variant
    arColorIndex = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, _
                        10, 11, 12, 13, 14, 15, 16, _
                        33, 34, 35, 36, 37, 38, 39, _
                        40, 41, 42, 43, 44, 45, 46, 47, 48, 49, _
                        50, 51, 52, 53, 54, 55, 56)
    tmpColorIndex = -1
    flgBold = False
    flgItalic = False
    flgStrikethrough = False
    tmpUnderLine = xlUnderlineStyleNone

    Dim a As Range
    Set a = Range("A1:A10")
    For Each tmpRange In a
                                                'シートが保護されているとこのマクロはエラーが発生する
    'For Each tmpRange In ActiveSheet.UsedRange  'UsedRangeは使用している範囲全体が全て選択される
        If Not IsError(tmpRange.Value) Then     '#VALUE!や#DIV/0!などのエラーがあるとValueが参照できない
            If tmpRange.Value  "" Then
                tmpCount = tmpCount + 1
            End If
        End If
    Next
    If tmpCount = 0 Then
        response = MsgBox("文字・数値が入力されているセルがありません", vbOKOnly + vbCritical, "エラー")
        Exit Function
    End If

    search_char = str1
    'search_char = InputBox("書式設定したい文字列を入力してください", "検索文字の指定")
    search_char_len = Len(search_char)
    If search_char_len = 0 Then
        Exit Function
    End If

    Do While tmpColorIndex = -1
        tmpValue = color1
'        tmpValue = InputBox("検索文字に設定する色を次の中から数字で指定してください" & vbCr & vbCr & _
'                            "0:自動 , 1:黒 , 2:白 , 3:赤 , 4:明るい緑 , 5:青 , 6:黄 ," & vbCr & _
'                            "7:ピンク , 8:水色 , 9:濃い赤 , 10:緑 , 11:濃い青 , 12:濃い黄 ," & vbCr & _
'                            "13:紫 , 14:青緑 , 15:25%灰色 , 16:50%灰色 , 33:スカイブルー ," & vbCr & _
'                            "34:薄い水色 , 35:薄い緑 , 36:薄い黄 , 37:ペールブルー ," & vbCr & _
'                            "38:ローズ , 39:ラベンダー , 40:ベージュ , 41:薄い青 ," & vbCr & _
'                            "42:アクア , 43:ライム , 44:ゴールド , 45:薄いオレンジ ," & vbCr & _
'                            "46:オレンジ , 47:ブルーグレー , 48:40%灰色 , 49:濃い青緑 ," & vbCr & _
'                            "50:シーグリーン , 51:濃い緑 , 52:オリーブ , 53:茶 ," & vbCr & _
'                            "54:プラム , 55:インディゴ , 56:80%灰色", "文字色の指定", 0)
        If IsNumeric(tmpValue) Then
            For i = 1 To 41                                             'option base 1 が前提
                If Val(tmpValue) = arColorIndex(i) Then
                    tmpColorIndex = Val(tmpValue)
                    Exit For
                End If
            Next
        End If
    Loop

    flgBold = True  '太字
'    response = MsgBox("検索文字をにしますか?", _
'                vbYesNoCancel + vbQuestion + vbDefaultButton2, "書式")
'    If response = vbYes Then
'        flgBold = True
'    Else
'        If response = vbCancel Then
'            Exit Sub
'        End If
'    End If
'    response = MsgBox("検索文字をにしますか?", _
'                vbYesNoCancel + vbQuestion + vbDefaultButton2, "書式")
'    If response = vbYes Then
'        flgItalic = True
'    Else
'        If response = vbCancel Then
'            Exit Sub
'        End If
'    End If
'    response = MsgBox("検索文字にを付けますか?", _
'                vbYesNoCancel + vbQuestion + vbDefaultButton2, "書式")
'
'    '下線にはSingle,Double,各会計用の4種類あるが、今回はsingle下線のみ
'    If response = vbYes Then
'        tmpUnderLine = xlUnderlineStyleSingle
'    Else
'        If response = vbCancel Then
'            Exit Sub
'        End If
'    End If
'    response = MsgBox("検索文字にを付けますか?", _
'                vbYesNoCancel + vbQuestion + vbDefaultButton2, "書式")
'    If response = vbYes Then
'        flgStrikethrough = True
'    Else
'        If response = vbCancel Then
'            Exit Sub
'        End If
'    End If

    tmpFontStyle = "標準"
    If flgBold Then
        tmpFontStyle = "太字"
        If flgItalic Then
            tmpFontStyle = "太字 斜体"
        End If
    Else
        If flgItalic Then
            tmpFontStyle = "斜体"
        End If
    End If

    tmpCount = 0
    start_pos = 0
    For Each tmpRange In a
    'For Each tmpRange In ActiveSheet.UsedRange
        If Not IsError(tmpRange.Value) Then  '#VALUE!や#DIV/0!などのエラーがあるとValueが参照できない
            start_pos = InStr(1, tmpRange.Value, search_char, 0)
            Do While start_pos > 0
                tmpRange.Select
                With ActiveCell.Characters(Start:=start_pos, Length:=search_char_len).Font
                    .ColorIndex = tmpColorIndex
                    .Underline = tmpUnderLine
                    .Strikethrough = flgStrikethrough
                    .FontStyle = tmpFontStyle
                End With
                tmpCount = tmpCount + 1
                start_pos = InStr(start_pos + Len(search_char), tmpRange.Value, search_char, 0)
            Loop
        End If
    Next

'    response = MsgBox(tmpCount & " 箇所に書式を設定しました。", _
'                                    vbOKOnly + vbInformation, "処理終了")
'
End Function

Sub FormatClear()
    Range("A1:A10").Font.Bold = False
    Range("A1:A10").Font.ColorIndex = xlAutomatic
End Sub
Etc.

Utilizing for loop and logical conditions (if, else) with VBA

We previously learned how to access a cell and modify its properties. In this post, We will see how to use power of loops and logical conditions to execute the same task multiple times. 289 more words

Excel VBA

Simple Toggle to Change View

Here’s a simple bit of code which combined with a toggle button allows the user to change the view of a worksheet. 349 more words

VBA

Setting Up a Debug Environment for VBA

VBA supports Conditional Compilation. Most often this is used to switch between different methods based on whether the installed version of Office is 32 or 64 bit, but it can also be used to set up a kind of debugging environment. 605 more words

VBA

Exporting Parts Lists from Drawings to Excel With Thumbnails in VBA

So, I cruise around the Inventor User Group on LinkedIn from time to time, and yesterday a post caught my eye. An inventor user asked if it was possible to save BOMs to Excel with thumbnails. 349 more words

Excel