IT系/VBA/実例集・サンプル

• Prev
• Next
• IT系/VBA

---

目次

---

概要

VBAの実例集・サンプルのリンク集。

セル・シート関連

最終行・列取得

https://qiita.com/itagakishintaro/items/6715497d6e8af24a068e

Function 最終行取得(SHEET As Worksheet, COLUMN As Integer) As Integer
    最終行取得 = SHEET.Cells(Rows.Count, COLUMN).End(xlUp).Row
End Function

MaxCol = Cells(1, Columns.Count).End(xlToLeft).Column

http://www.niji.or.jp/home/toru/notes/8.html

With ActiveSheet.UsedRange
    MaxRow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
    MaxCol = .Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
End With

検索

https://qiita.com/itagakishintaro/items/6715497d6e8af24a068e

Function 検索(range As Variant, KEYWORD As String) As Integer
    Dim cell As Variant
    Set cell = range.Find(What:=KEYWORD, LookAt:=xlPart)
    If cell Is Nothing Then
        MsgBox "検索に失敗しました"
    Else
        検索 = cell.Row
    End If
End Function

シート名取得

https://qiita.com/hokupod/items/808162369d5a44de8588

' アクティブブックの全シート名を取得し、配列で返します。
Public Function SheetNameCollect()
    Dim i As Long
    Dim SheetCnt As Long
    Dim SheetName() As String
    '
    SheetCnt = ThisWorkbook.Sheets.Count
    '
    ReDim SheetName(0 To SheetCnt - 1)
    For i = 0 To SheetCnt - 1
        SheetName(i) = Sheets(i + 1).Name
    Next i
    SheetNameCollect = SheetName
End Function

セルの座標(レンジ)を取得

https://qiita.com/hokupod/items/808162369d5a44de8588

' 引数：key -> 検索文字列
' 引数：SheetName -> 検索するシート名
' 引数：range -> 行や列のレンジ(ex. 1:1)
Public Function SearchRange(key, SheetName, range) As String
    Dim c As Object
    Dim myKey As String, fAddress As String
    fAddress = ""
    myKey = key
    With Worksheets(SheetName).range(range)
        Set c = .Find(What:=myKey, LookIn:=xlValues, lookat:=xlPart, _
                          SearchOrder:=xlByColumns, MatchByte:=False)
        If Not c Is Nothing Then
            fAddress = c.Address
        End If
    End With
    SearchRange = fAddress
End Function

ワークシートをコピー

https://qiita.com/_ha1f/items/4d1c7ab65ea0f569d51f

' ActiveWorksheetを維持したまま、ワークシートをコピー、ワークシートの参照を返す
Function CopyWorksheet(ByVal templateSheet As Variant) As Worksheet
    Dim preActivesheet As Worksheet
    Set preActivesheet = ActiveSheet
    Dim succeeded As Boolean
    succeeded = templateSheet.Copy(After:=Worksheets(Worksheets.Count))
    Dim newSheet As Worksheet
    Set newSheet = ActiveSheet
    preActivesheet.Activate
    Set CopyWorksheet = newSheet
End Function

シート存在判定関数

https://qiita.com/nukie_53/items/8ee969555da3396486ce

'`inSheets`の中から、`inName`の名前のシートを探す。
'見つかった場合、`True`を返し、`outFindSheet`に見つかったシートオブジェクトを設定する。
'見つからなかった場合、`False`を返す(`outFindSheet`は変更されない)。
'
'引数
    'inSheets       :探索対象のシート群。`ThisWorkbook.Worksheets`などを指定する。
    'inName         :探索するシートの名前。
    'outFindSheet   :返り値用引数(参照渡し)。見つかったシート。As Excel.Worksheet | Excel.Chart | Excel.DialogSheet
'
'返り値
    '`inName`のシートが見つかった場合`True`、それ以外は`False`。
'
Public Function TryFindSheet( _
                       inSheets As Excel.Sheets, _
                       inName As String, _
        Optional ByRef outFindSheet As Object _
    ) As Boolean
    '
    'Excelのシート名は、
    '半角全角・大文字小文字を同一視し、
    'ひらがなカタカナを異なるものと判断する。
    'VBAには同じ方法で文字列を比較する方法が無いため、
    '半角全角・大文字小文字をStrConvで揃えてからvbBinaryCompareで比較する。
    Dim convOption As VBA.VbStrConv
    convOption = vbNarrow Or vbUpperCase '半角大文字へ変換する。
    Const JP_LCID = 1041
    '
    '引数の半角全角・大文字小文字を揃える。
    Dim argAsNarrowUpper As String
    argAsNarrowUpper = VBA.Strings.StrConv(inName, convOption, JP_LCID)
    '
    Dim sht As Object 'As Excel.Worksheet | Excel.Chart | Excel.DialogSheet
    For Each sht In inSheets
        '各シートの名前の半角全角・大文字小文字を揃える。
        Dim tmpName As String
        tmpName = VBA.Strings.StrConv(sht.Name, convOption, JP_LCID)
        '
        'vbBinaryCompareで文字列比較。
        If VBA.Strings.StrComp(argAsNarrowUpper, tmpName, vbBinaryCompare) = 0 Then
            '同じであれば見つかったと判断。
            Set outFindSheet = sht
            Let TryFindSheet = True
            Exit Function
        End If
    Next sht
    'return False
End Function

Worksheetにあるチェックボックスのステータス一括確認

https://qiita.com/Dace_K/items/31bc3f1ab28749e72656

Sub Macro1()
    '変数定義
    Dim n, i, cnt
    'チェックボックスがTrue（チェックありもの）のカウントを行う
    With Worksheets("sheet1")
        For i = 1 To n
            If .OLEObjects("Checkbox" & i).Object.Value = True Then
                cnt = cnt + 1
            End If
        Next i
    End With
End Sub

チェックボックスのタイトル（Caption）を取得

https://qiita.com/Dace_K/items/31bc3f1ab28749e72656

Sub Macro2()
    '変数定義
    Dim Caption
    'タイトル（Caption）を取得する
    Caption = Worksheet("sheet1").OLEObjects("Checkbox1").Object.Caption
End Sub

ブック関連

シークレットオープン

https://qiita.com/itagakishintaro/items/6715497d6e8af24a068e

Sub シークレットオープン(BOOK As Workbook, F As String)
    Dim excelApp: Set excelApp = CreateObject("Excel.Application")
    excelApp.Visible = False
    excelApp.DisplayAlerts = False
    Set BOOK = excelApp.Workbooks.Open(FILENAME:=F, ReadOnly:=True)
End Sub

フォルダ配下のexcelファイルをすべて開く

Dim FSO As New FileSystemObject ' FileSystemObject
Dim FOLDER As String
FOLDER = ThisWorkbook.PATH & "\data\"
Dim FILE As Object
For Each FILE In objFSO.getfolder(FOLDER).Files
    Dim BOOK As Workbook
    シークレットオープン BOOK, FOLDER & FILE.Name
    ' ここに処理をかく
    BOOK.Close SaveChanges:=False
Next FILE

文字列関連

全角半角変換

https://qiita.com/itagakishintaro/items/6715497d6e8af24a068e

Function 全角半角変換(str As String) As String
    Dim i As Integer
    Dim tmp As String
    For i = 1 To Len(str)
        If Mid(str, i, 1) Like "[ｱ-ﾝ]" Then
            tmp = tmp & StrConv(Mid(str, i, 1), vbWide)
        ElseIf Mid(str, i, 1) Like "[０-９]" _
            Or Mid(str, i, 1) Like "[Ａ-ｚ]" _
            Or Mid(str, i, 1) Like "（" _
            Or Mid(str, i, 1) Like "）" _
            Or Mid(str, i, 1) Like "—" _
        Then
            tmp = tmp & StrConv(Mid(str, i, 1), vbNarrow)
        Else
            tmp = tmp & Mid(str, i, 1)
        End If
    Next
    全角半角変換 = tmp
End Function

特殊文字変換

https://qiita.com/itagakishintaro/items/6715497d6e8af24a068e

Sub 特殊文字変換(str As String)
    range(str).Select
    With Selection
        .Replace What:="㈱", Replacement:="(株)"
'財と社の機種依存文字はVBEで入力できないので、断念
'        .Replace What:="?", Replacement:="(財)"
'        .Replace What:="?", Replacement:="(社)"
        .Replace What:="㈲", Replacement:="(有)"
    End With
End Sub

取消線文字削除

https://qiita.com/itagakishintaro/items/6715497d6e8af24a068e

Function 取消線文字削除(CELL As Variant)
    Dim textBefore As String
    textBefore = CELL.VALUE
    Dim textAfter As String
    textAfter = ""
    Dim i As Integer
    For i = 1 To Len(textBefore)
        If CELL.Characters(Start:=i, Length:=1).Font.Strikethrough = False Then
            textAfter = textAfter & Mid(textBefore, i, 1)
        End If
    Next i
    取消線文字削除 = textAfter
End Function

改行削除

https://qiita.com/itagakishintaro/items/6715497d6e8af24a068e

Function 改行削除(TEXT As String) As String
    改行削除 = Replace(Replace(Replace(TEXT, vbLf, ""), vbCr, ""), vbCrLf, "")
End Function

末尾クリア

https://qiita.com/itagakishintaro/items/6715497d6e8af24a068e

Function 末尾クリア(TEXT As String) As String
    Do Until Right(TEXT, 1) <> vbLf And Right(TEXT, 1) <> vbCr And Right(TEXT, 1) <> vbCrLf
        TEXT = Left(TEXT, Len(TEXT) - 1)
    Loop
    末尾クリア = Trim(TEXT)
End Function

ファイル関連

文字コード変換

https://qiita.com/itagakishintaro/items/6715497d6e8af24a068e

Public Sub 文字コード変換(FILENAME As String, BEFORE As String, AFTER As String)
    Dim 前ファイル As Object
    Dim 後ファイル As Object
    Set 前ファイル = CreateObject("ADODB.Stream")
    With 前ファイル
        .Type = 2
        .Charset = BEFORE
        .Open
        .LoadFromFile FILENAME
        .Position = 0
    End With
    Set 後ファイル = CreateObject("ADODB.Stream")
    With 後ファイル
        .Type = 2
        .Charset = AFTER
        .Open
    End With
    前ファイル.copyto 後ファイル
    後ファイル.Position = 0
    後ファイル.savetofile FILENAME, 2
End Sub

UTF-8のBOMなしにする場合

https://qiita.com/itagakishintaro/items/6715497d6e8af24a068e

Public Sub 文字コード変換(FILENAME As String, BEFORE As String, AFTER As String)
    Dim 前ファイル As Object
    Dim 後ファイル As Object
    Set 前ファイル = CreateObject("ADODB.Stream")
    With 前ファイル
        .Type = 2
        .Charset = BEFORE
        .Open
        .LoadFromFile FILENAME
        .Position = 0
    End With
    Set 後ファイル = CreateObject("ADODB.Stream")
    With 後ファイル
        .Type = 2
        .Charset = AFTER
        .Open
    End With
    前ファイル.copyto 後ファイル
    ' BOM削除
    Dim byteData() As Byte
    With 後ファイル
        .Position = 0
        .Type = 1
        .Position = 3
        byteData = 後ファイル.Read
        .Close
        .Open
        .Write byteData
    End With
    後ファイル.savetofile FILENAME, 2
End Sub

拡張子を除いたファイル名を取得

https://qiita.com/_ha1f/items/4d1c7ab65ea0f569d51f

'拡張子を除いたファイル名の取得
Function GetPureName(sFileName As String) As String
    Dim pureName As String
    pureName = Left(sFileName, InStrRev(sFileName, ".") - 1)
    GetPureName = pureName
End Function

配列

配列内の特定要素のインデックス番号を取得

https://qiita.com/hokupod/items/808162369d5a44de8588

' 引数：TargetArray -> 添え字を確認したい配列
' 引数：element -> 要素(文字列等)
' 戻り値：インデックス番号
Public Function IndexOf(TargetArray, element)
    For i = 0 To UBound(TargetArray)
        If TargetArray(i) = element Then Exit For
    Next
    IndexOf = i
End Function

配列の要素を削除

https://qiita.com/hokupod/items/808162369d5a44de8588

' 引数：TargetArray -> 対象の配列
' 引数：deleteIndex -> 削除したい要素のインデックス番号
Public Sub ArrayRemove(ByRef TargetArray As Variant, ByVal deleteIndex As Integer)
    Dim i As Integer
    '削除したい要素以降の要素を前につめて上書きコピー
    For i = deleteIndex To UBound(TargetArray) - 1
        TargetArray(i) = TargetArray(i + 1)
    Next i
    '最後の要素を削除する（配列を再定義）
    ReDim Preserve TargetArray(UBound(TargetArray) - 1)
End Sub

次元取得

https://qiita.com/nukie_53/items/bde16afd9a6ca789949d

'配列の次元数を取得する。初期化していない動的配列の場合は0
Public Function DimensionsOf(anyArray As Variant) As Long
    If Not VBA.IsArray(anyArray) Then Err().Raise 13
    'VBAの多次元配列の次元の上限
    Const MAX_ARRAY_DIMENSION = 60
    Dim d As Long, no_mean_var As Long
    On Error Resume Next
        For d = 1 To MAX_ARRAY_DIMENSION
            no_mean_var = LBound(anyArray, d)
            If Err.Number <> 0 Then Exit For
        Next d
    On Error GoTo 0
    'VBAのFor文は完走すると指定した数値+1になる
    Let DimensionsOf = (d - 1) '0 To 60
End Function

要素数取得

https://qiita.com/nukie_53/items/bde16afd9a6ca789949d
Public Function SizeOfArray( _

       anyArray As Variant, _
       Optional dimension As Long = 1 _
   ) As Long
   Let SizeOfArray = UBound(anyArray, dimension) - LBound(anyArray, dimension) + 1

End Function

アプリケーション連携関連

アプリケーション起動

https://qiita.com/hokupod/items/808162369d5a44de8588

' 引数：path -> 開きたいファイルのパス
Public Sub OpenFile(path)
    Dim WSH As Object
    Set WSH = CreateObject("Wscript.Shell")
    WSH.Run path, 3
    Set WSH = Nothing
End Sub

指定したアプリケーションを実行

Sub Macro3()
    '指定したアプリケーションを実行させる（ex.メモ帳）
    Shell "notepad.exe"
End Sub

指定したアプリケーションをアクティブ表示

https://qiita.com/Dace_K/items/31bc3f1ab28749e72656

Sub Macro4()
    '指定したアプリケーションをアクティブ表示させる
    AppActivate "Microsoft Excel", True
End Sub

他

ページ設定

https://qiita.com/kyokugenultimate/items/d4402e688da1570beaf1

Sub quickPageSetup()
'よく使うページ設定を素早く実行
　　Application.ScreenUpdating = False '描画を省略
　　With ActiveSheet.PageSetup
　　　　.CenterFooter = "&P/&N" 'ページ数/総ページ数　→中央フッタ
　　　　.LeftMargin = Application.InchesToPoints(0.4)　　　'左余白。やや広く。
　　　　.RightMargin = Application.InchesToPoints(0.2)　　 '右余白。狭く。
　　　　.TopMargin = Application.InchesToPoints(0.4)　　　 '上余白。
　　　　.BottomMargin = Application.InchesToPoints(0.4)　　'下余白。
　　　　.HeaderMargin = Application.InchesToPoints(0.2)　　'ヘッダ。
　　　　.FooterMargin = Application.InchesToPoints(0.2)　　'フッタ。
　　　　.Zoom = False
　　　　.FitToPagesWide = 1 '横1ページに収める
　　　　.FitToPagesTall = False '縦のページ数は設定しない
　　End With
　　Application.ScreenUpdating = True '描画する
End Sub

XXX

XXX

XXX

XXX

XXX

XXX

XXX

XXX

XXX

XXX

XXX

XXX

XXX

XXX

XXX

XXX

XXX

XXX

リンク集

重複を恐れないリンク集。

https://qiita.com/hayakawa_qiita/items/f783e42e4bcece87c1c0
https://qiita.com/johnslith/items/21e2f4c220fecc2365db

• VBAを定型文で覚えよう｜VBA技術解説
• VBAこれだけは覚えておきたい必須基本例文10｜VBA技術解説
• 時刻になったら音を鳴らして知らせる（OnTime）｜VBAサンプル集
• 指定文字、指定数式でジャンプ機能（Union）｜VBAサンプル集
• 「値の貼り付け」をショートカットに登録（OnKey）｜VBAサンプル集
• 「セルの結合」をショートカットに登録（OnKey）｜VBAサンプル集
• 計算式の元となる数値定数を消去する（Precedents）｜VBAサンプル集
• ユーザー定義関数でフリガナを取得する（GetPhonetic）｜VBAサンプル集
• ユーザー定義関数でハイパーリンクのURLを取得（Hyperlink）｜VBAサンプル集
• カラーのコード取得、256RGB⇔16進変換｜VBAサンプル集
• 月別ブックより部署別シートに担当別に集計するNo1｜VBA再入門
• 月別ブックより部署別シートに担当別に集計するNo2｜VBA再入門
• 月別ブックより部署別シートに担当別に集計するNo3｜VBA再入門
• 月別ブックより部署別シートに担当別に集計するNo4｜VBA再入門
• 月別ブックより部署別シートに担当別に集計するNo5｜VBA再入門
• 素数を求めるマクロ｜VBAサンプル集
• 順列の全組み合わせ作成と応用方法｜VBAサンプル集
• ADOでマスタ付加と集計（SQL）｜VBAサンプル集
• ADOでマスタ更新（SQL）｜VBAサンプル集
• アメブロの記事本文をVBAでバックアップする№1｜VBAサンプル集
• 数独（ナンプレ）を解くVBAに挑戦№1｜VBAサンプル集
• 数独（ナンプレ）を解くアルゴリズムの要点とパフォーマンスの検証№1｜VBAサンプル集
• ナンバーリンク(パズル)を解くVBAに挑戦№1｜VBAサンプル集
• ナンバーリンクを解くVBAのパフォーマンス改善№1｜VBAサンプル集
• オセロを作りながらマクロVBAを学ぼう｜VBAサンプル集
• 他ブックへのリンクエラーを探し解除｜VBAサンプル集
• Excelシートの複雑な計算式を解析するVBA｜VBAサンプル集
• エクセル顧客管理｜エクセルの神髄

その他メモ

---

• Prev
  IT系/VBA/基本/開発環境（VBE）
• Next
  IT系/VBA/性能
• Home
  Up