ExcelのVBA

サブトピック†

↑

一般†

VBAからSQL Serverに接続する方法(Microsoft OLE DB Provider for SQL Server) | Skill Note 2023.4

XML 要素を XML マップのセルに対応付ける - Microsoft サポート 2023.2

【VSCode】XVBAを使ってExcel VBA開発 | とあるエンジニアの備忘録 2022

Excel VBAでもう頑張らない | フューチャー技術ブログ 2023.2

VarTypeで8204などが返ってくるとき
- 配列を指定した場合は、配列(8192)+型番号の値が返ります。8204ならVariant(12)の配列
- http://www.openreference.org/articles/view/460

VBA100本ノック：マクロVBAの特訓｜エクセルの神髄 2021.3

エクセルアドインとは

エクセルＶＢＡ・マクロ勉強参考サイトまとめ

コントロールの誤操作でマクロが作成される

VB & VBAプログラミング

すぐに役立つVBAマクロ集
- 印刷（基本型）

ExcelRelaxTools Addin 2014.1.29
- 5年間(2009年～)にわたって作成したマクロを汎用的、体系的にまとめたものです。

↑

Tips†

↑

警告抑制†

Application.DisplayAlerts = False '警告抑制

↑

スクレイピング †

時給１０００円の事務員さんのための VBA スクレイピング 2019.5

↑

アドイン関連†

VBAをリボンUIに追加する（インストーラー付き） 2017.7.17

↑

ExcelにGoogle Maps APIで地図を埋め込み、住所検索、拡大／縮小、地図種類変更†

http://www.atmarkit.co.jp/ait/articles/1409/05/news165.html

↑

開いているファイルの中から名前の左側が引数と合致するファイルを探す†

'２つ以上あったらエラー
Function schFile(name As String) As Workbook

    Dim cnt As Integer
    cnt = 0

    Set schFile = Nothing

    Dim bk As Workbook
    For Each bk In Workbooks
        Dim ln As Integer
        ln = Len(name)
        Debug.Assert (ln > 0)
        If StrConv(Left(bk.name, ln), vbUpperCase) = StrConv(name, vbUpperCase) Then
            If Not (schFile Is Nothing) Then
                MsgBox ("[" & name & "]で始まるファイルが２つ以上あります")
                End
            End If

            Debug.Assert (schFile Is Nothing)  '同じ名前で始まるファイルが２つ以上あったらエラーになります
            Set schFile = bk
            'ここですぐは返らない　２つ以上あったらまずいから
        End If
    Next

    If schFile Is Nothing Then
        MsgBox ("[" & name & "]で始まるファイルが見つかりません")
        End
    End If

End Function

↑

countifsの数式を元に、同じ条件でフィルタをかける†

Sub 数式からフィルター(r As Range)
Dim strSuusiki As String
Dim varPrm As Variant
Dim sh As Worksheet
Dim ac As Worksheet
Dim lngLoop As Long
Dim lngColNo As Long
Dim strJoken As String
Dim rngFil As Range

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Set sh = Sheets("hoge")
    Set ac = r.Worksheet

    strSuusiki = r.Formula ''該当セルの数式を取り出す
    strSuusiki = Replace(strSuusiki, "=countifs(", "", , , vbTextCompare) '’余分なところを消す
    strSuusiki = Replace(strSuusiki, "=countif(", "", , , vbTextCompare) '’余分なところを消す
    strSuusiki = Replace(strSuusiki, ")", "") '’余分なところを消す
    varPrm = Split(strSuusiki, ",") '’Countifsのパラメータのみを配列に分割する

    If Not sh.AutoFilterMode Then ''オートフィルターが付いてない場合
        Intersect(sh.UsedRange, sh.Range("10:65535")).AutoFilter '’フィルターをつける
    End If

    If sh.FilterMode Then '’フィルターがかかっている状態のときはフィルタークリア
        sh.ShowAllData
    End If

    Set rngFil = sh.AutoFilter.Range

    For lngLoop = 0 To UBound(varPrm) Step 2
        lngColNo = Range(varPrm(lngLoop)).Column    ''配列の偶数番目＝検索条件範囲のカラム番号を取得
        strJoken = varPrm(lngLoop + 1)              ''配列の奇数番目＝検索条件を取得
        If InStr(strJoken, """") > 0 Then
            strJoken = Replace(strJoken, """", "") '’""がある場合は定数（””は消す）
        Else
            strJoken = ac.Range(strJoken).Value '’””がない場合はセルへの参照のため参照先の値を取得
        End If


        rngFil.AutoFilter Field:=lngColNo, Criteria1:=strJoken
    Next

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

↑

ハイパーリンクをクリックしたら上の行（３行目）にあげる†

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
   Dim r As Integer
   r = Target.Range.row
   If r = 3 Then
       Exit Sub
   Else
       ThisWorkbook.Worksheets(1).Activate
       Rows("3:3").Select
       Selection.EntireRow.Insert

       r = r + 1
       Rows(r & ":" & r).Select
       Selection.Cut
       Range("A3").Select
       ActiveSheet.Paste

       Range("A" & r).Select
       Selection.EntireRow.Delete
   End If
End Sub

↑

セルの値を文字列として取得したい場合†

Cells(i,j).Text

↑

フィルタ系†

フィルタをクリアする
```
ActiveSheet.ShowAllData
```

行が非表示か判定する
- Range.Hiddenプロパティを見る

オートフィルタ適用後に表示されている行のみを対象に処理を行う

↑

現在見ているブックの全シートから_YMDHMSという値の入ったセルをすべて探し、その下にあるセルにフォーマットを設定する†

 Sub 日付のフォーマット修正()
   Debug.Print ("フォーマット修正開始")
   Dim bk As Workbook
   Dim sht As Worksheet
   Set bk = ActiveWorkbook
   Dim i As Integer
   For i = 1 To bk.Worksheets.Count
       Set sht = bk.Worksheets(i)
       With sht
           .Activate
           .Cells(1, 1).Select
           Dim r As Range
           Set r = Cells.Find(What:="_YMDHMS", After:=ActiveCell, LookIn:=xlValues, _
               LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
               MatchCase:=False, MatchByte:=False, SearchFormat:=False)
           If Not r Is Nothing Then
               Dim firstPos As String
               firstPos = r.Address
               Do
                   Dim s As String
                   .Cells(r.row, r.Column).Select
                   If Trim(.Cells(r.row + 1, r.Column)) <> "" Then
                       s = .Cells(r.row, r.Column)
                       Debug.Print (.Name & ":" & r.row & "," & r.Column & "," & s)
                       .Cells(r.row + 1, r.Column).NumberFormatLocal = "yyyy-mm-dd hh:mm:ss"
                       .Cells(r.row + 1, r.Column).HorizontalAlignment = xlLeft
                       Dim rcol As Range
                       Set rcol = .Columns(r.Column)
                       rcol.AutoFit
                   End If
                   Set r = Cells.FindNext(r)
                   DoEvents
               Loop While (r.Address <> firstPos)
           Else
               'そもそもない
           End If
       End With
   Next
   MsgBox ("OK")
 End Sub

↑

今選択しているシート†

Application.SelectedSheets を参照する

↑

「名前」の全消し†

メニューから消していると一回に１つしか消せなくて面倒なので、以下のマクロで
```
for i = ActiveWorkbook.Names.Count to 1 step -1
  ActiveWorkbook.Names(i).Delete
Next
```

↑

パスワード付きでブックを保存する†

ActiveWorkbook.SaveAs Filename:= _
"hoge.xls", FileFormat:= _
xlExcel8, Password:="anestec", WriteResPassword:="", ReadOnlyRecommended _
:=False, CreateBackup:=False

↑

手っ取り早くExcelシートの一覧を得るには†

ALT+F11を押下(VBAエディタが起動)
CTRL+Gを押下(イミディエイトウインドウが起動)
```
For Each i In ThisWorkbook.Sheets: debug.print i.name : next i 
```
をタイプしてEnterを押下

↑

［Esc］キーによるExcel VBAの実行中断を防止する†

http://www.atmarkit.co.jp/fwin2k/win2ktips/1437disescexcl/disescexcl.html
```
Application.EnableCancelKey = xlDisabled
```

↑

互換性チェックのダイアログが出るのを抑制†

Office2007で .xlsファイルを保存しようとしたときに出るダイアログを抑制したい場合は、上書き確認の抑制と同じように
```
Application.DisplayAlerts=False
```
とする

↑

Excelで特定の値になったときのアクション†

特定のセルに特定の値が入力されたときにマクロを自動的に実行するには？
- http://www.asahi-net.or.jp/~zn3y-ngi/YNxv9c7.html
- WorkSheet_Changeのイベントプロシージャに処理を書けば良い。当然ながらExcelの設定でマクロ実行を許可しておく必要はある（オプションのセキュリティ設定）

↑

ツリービューコントロール†

Tree View Controlの組み込み
- 「ツール」-「その他のコントロール」から「Microsoft TreeView Control」を選択
http://www.f3.dion.ne.jp/~element/msaccess/AcTipsFrmUsingTreeView1.html
http://www.tsware.jp/study/indexv10.htm
http://www.int21.co.jp/pcdn/vb/noriolib/vbmag/9710/aki/

↑

VBA コンパイルエラーと実行時エラー†

http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_200_020.html
Excel2002からある模様
コンパイルの機能はタイプミスなどのチェックをするためのものと考える

↑

Shift JIS文字列をUTF-8に†

Public Function encodeUTF8(ByRef strUni As String) As Byte()
   encodeUTF8 = ADOS_Encode("UTF-8", strUni)
End Function

Private Function ADOS_Encode(ByVal cset As String, ByRef strUni As String) As Byte()
   Dim objStm As ADODB.Stream
   Set objStm = New ADODB.Stream
   objStm.Open
   objStm.Type = adTypeText
   objStm.Charset = cset
   objStm.WriteText strUni

   objStm.Position = 0
   objStm.Type = adTypeBinary
   Select Case UCase(cset)
     Case "UNICODE", "UTF-16"
       objStm.Position = 2
     Case "UTF-8"
       objStm.Position = 3
   End Select
   ADOS_Encode = objStm.Read()

   objStm.Close

End Function

↑

描画抑制†

Application.ScreenUpdating = false

↑

シート並べ替えサンプル†

１シート目の2行目2列目からシート名を並べておき、その順番に２番目以降のシートを入れ替えるマクロの例（ちょっとバグってるかも…）

Sub シート並べ替え()

   Dim bk As Workbook
   Set bk = ThisWorkbook

   Dim sht As Worksheet
   Set sht = ActiveSheet

   Dim names() As String
   Dim i As Integer

   'シート名読み込み
   Dim j As Integer
   j = 0
   For i = 2 To 1000 'とりあえず1000シートまで
       If sht.Cells(i, 2) <> "" Then
           ReDim Preserve names(j)
           names(j) = sht.Cells(i, 2)
           j = j + 1
       Else
           Exit For
       End If
   Next

   For i = 0 To UBound(names)
       Dim wsht As Worksheet
       Set wsht = bk.Worksheets(names(i))
       Call wsht.Move(After:=bk.Worksheets(1 + i))
   Next

   MsgBox ("OK")

End Sub

↑

Excelシートアルファベット順並べ替え†

http://park7.wakwak.com/~efc21/cgi-bin/exqalounge.cgi?print+200610/06100285.txt

↑

列幅を合わせる†

   'ost は対象シート
   ost.Activate
   ost.Range(ost.Cells(1, 1), ost.Cells(osr, 8)).Columns.AutoFit

columnsに対して行うのがポイント

↑

マクロのあるブック†

ThisWorkbookで参照

↑

AddTextBox に渡す座標の渡し方†

http://www.keep-on.com/excelyou/2001lng4/200102/01020461.txt
Cells().Leftとか.Topとかを利用するとよい

↑

ブックのシートインデックスを作る†

最初のシートに「目次」という名前をつけるのであらかじめ用意しておく

Sub MakeIndex()
   
   Dim s_シート名() As String
   
   Dim mokuji As Worksheet
   Set mokuji = Worksheets(1)
   mokuji.Name = "目次"
   
   '《目次》シート情報
   Dim row As Integer
   Dim col As Integer
   row = 1
   col = 2

   '  シート名取得
   mokuji.Select
   Dim J As Integer
   For J = 1 To Worksheets.Count
       ReDim Preserve s_シート名(J)
       s_シート名(J) = Worksheets(J).Name
   Next J
   
   mokuji.Activate

   '  取得結果反映
   Dim K As Integer
   For K = 2 To UBound(s_シート名)

       Dim sht_name As String
       sht_name = s_シート名(K)
       If sht_name <> "" Then
           Dim rnt As Range
           Set rnt = mokuji.Cells(K, col)
           mokuji.Hyperlinks.Add _
               Anchor:=rnt, _
               Address:="", SubAddress:="'" & sht_name & "'!A1", TextToDisplay:=sht_name
           mokuji.Cells(K, col).Select
       End If

   Next K
End Sub

↑

シートに画像を取り込み、その占めている範囲の右下セルを得る†

Dim acs As Worksheet
Set acs = ActiveSheet
acs.Cells(1, 1).Select
acs.Pictures.Insert(画像のpath).Select
Dim r As Range
Set r = acs.Pictures(1).BottomRightCell

↑

いらないシートを消す†

   Application.DisplayAlerts = False '警告抑制
   With outbook
       '本当は３つとは限らないが（Excelの設定によって変わるので）、とりあえず
       .Worksheets("Sheet1").Delete
       .Worksheets("Sheet2").Delete
       .Worksheets("Sheet3").Delete
   End With

※シート数を０にはできませんので注意

↑

プログラムの同期的な実行†

→Visual Basic(.NET以前)のページを見よ

↑

表示倍率を変える†

ActiveWindow.Zoom = 75

↑

ハイパーリンク作成†

表示文字列 = "hoge"
アドレス = "http://www.kernel-net.ne.jp/tech/"
Range("A1").Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, _
       Address:=アドレス, TextToDisplay:=表示文字列

削除

Range("A1").Hyperlinks.Delete
Range("A1").ClearContents

↑

印刷設定右下にページ数を入れる†

ActiveSheet.PageSetup.RightFooter = "&P/&N"

↑

印刷範囲の設定†

ActiveSheet.PageSetup.PrintArea = "$A$1:$N$83" 'A1形式 Rangeではダメです

↑

RangeからA1形式の文字列を得るには†

str = Cells(row, col).Address

↑

Worksheets.AddのAfter引数などで渡すのはシート名ではない†

シートの番目でもない。Worksheetのオブジェクトを渡さないといけないので注意
```
'ブック末尾へのシート追加
Worksheets.Add after:=Worksheets(Worksheets.Count)
```
Worksheet.Move や .Copyも同様

↑

VBAでデータが変わった切れ目で改ページしたい†

http://oshiete1.goo.ne.jp/qa1919970.html

Worksheets(SheetName).Range("B" + Trim$(Str$(rindex))).Activate
ActiveWindow.SelectedSheets.HPageBreaks.Add ActiveCell '改ページ挿入
ActiveWindow.SelectedSheets.VPageBreaks.Add ActiveCell

↑

印刷改ページを調整する†

'印刷ブレーク位置微調整 13桁目だったら右に１つずらす
'直接指定できないのだろうか?
Function adjust_print(st As Worksheet) As Integer

        Debug.Print (st.Name)
        st.Activate
        st.Cells(1, 14).Select
        
        'これでは変わってくれないようだ
        If st.VPageBreaks.Count = 0 Then
            st.VPageBreaks.Add st.Range("N1")
        Else
            st.VPageBreaks(1).Location = st.Range("N1")
        End If
        
        'こうしないとあわせられないのだろうか?
        If st.VPageBreaks(1).Location.Column = 13 Then
            ActiveWindow.View = xlPageBreakPreview
            ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
            ActiveWindow.View = xlNormalView
        End If
        
        st.Cells(1, 1).Select

    adjust_print = 0
End Function

Sub 印刷位置合わせ()
'
    Dim shts As Sheets
    Set shts = ActiveWorkbook.Worksheets
    Dim i As Integer
    Dim st As Worksheet
    
    '対象シート毎
    For i = 4 To shts.Count
        Set st = shts(i)
        Call adjust_print(st)
        DoEvents
    Next
    
End Sub

↑

CSV形式で保存する†

ActiveWorkbook.SaveAs Filename:="hoge.csv", FileFormat:=xlCSV, CreateBackup:=False

↑

データのある最後の行を返す†

e=Worksheets("sheet1").Range("A1").End(xlDown).Row

もしくは

e=Worksheets("sheet1").Range("A65536").End(xlUp).Row 'データ中に空き行がある場合

上のやり方では、列なら２列以上ないと256が返ってしまうので、下記のようにやる方がいいようだ。

Dim row As Integer
row = sht.UsedRange.Cells(sht.UsedRange.Count).row

Dim line As Integer
line = sht.UsedRange.Cells(sht.UsedRange.Count).Column

このやり方についてこちらのblog でご指摘あり。感謝

これは、データの入力の有無に関わらず、セルの一部に書式設定などがされていれば、
有効な範囲として値を返します。
すっきりとしていて、うまく行きそうですが、実は落とし穴になっています。

↑

ゴールシークを実行させる†

'E3の値が0になるようにB3を変化させる場合
Range("E3").GoalSeek Goal:=0, ChangingCell:=Range("B3")

↑

ブックを開いてシート毎になにかするサンプル†

Function prcBook(bk As String) As Integer
    
    Debug.Print ("-------book:" & bk & "スタート---------------------")
    
    Dim wbk As Workbook
    '指定 xls を開く
    'Set wbk = Application.Workbooks(bk)
    Set wbk = Workbooks.Open(bk)
    wbk.Activate
    
    Dim cnt As Integer
    cnt = wbk.Worksheets.Count
    Debug.Assert (cnt > 0)
    Dim i As Integer
    For i = 1 To cnt
        Dim wst As Worksheet
        Set wst = wbk.Worksheets(i)
        
        Call prcSheet(wst)
        
    Next
    
    wbk.Close
    Debug.Print ("-------処理終わり---------------------")

End Function

↑

VBAプロジェクトをロックする†

VBAの「ソースコードをロック」ではソースコードをロックできない - Qiita 2022.7

VBAのプロジェクトにパスワードを設定する:VBE(Visual Basic Editor) 2012
- プロジェクトのプロパティで「保護」シートで設定する

↑

VBAファイルのデータ構造†

Evil Clippy: MS Office maldoc assistant | Outflank 2019
- https://github.com/outflanknl/EvilClippy
- VBAのパスワード外すツール
- バイナリは用意されてないのでソースからコンパイルする必要がある。
```
Make sure you have Visual Studio installed. Then execute the following command from a Visual Studio developer command prompt:
csc /reference:OpenMcdf.dll,System.IO.Compression.FileSystem.dll /out:EvilClippy.exe *.cs
```

[MS-OVBA]: Office VBA File Format Structure | Microsoft Docs 2022.2

OpenMCDF is a 100% .net / C# component that allows developers to manipulate Microsoft Compound Document Files (also known as OLE structured storage). 2022.5

サブトピック†

一般†

Tips†

添付ファイルをつけてメール†

画面をキャプチャする†

Googleマップ表示†

CSVやExcelにSQLを実行†

マクロの自動実行を抑制†

警告抑制†

スクレイピング†

アドイン関連†

ExcelにGoogle Maps APIで地図を埋め込み、住所検索、拡大／縮小、地図種類変更†

開いているファイルの中から名前の左側が引数と合致するファイルを探す†

countifsの数式を元に、同じ条件でフィルタをかける†

ハイパーリンクをクリックしたら上の行（３行目）にあげる†

セルの値を文字列として取得したい場合†

フィルタ系†

現在見ているブックの全シートから_YMDHMSという値の入ったセルをすべて探し、その下にあるセルにフォーマットを設定する†

今選択しているシート†

「名前」の全消し†

パスワード付きでブックを保存する†

手っ取り早くExcelシートの一覧を得るには†

［Esc］キーによるExcel VBAの実行中断を防止する†

互換性チェックのダイアログが出るのを抑制†

Excelで特定の値になったときのアクション†

ツリービューコントロール†

VBA コンパイルエラーと実行時エラー†

Shift JIS文字列をUTF-8に†

描画抑制†

シート並べ替えサンプル†

Excelシートアルファベット順並べ替え†

列幅を合わせる†

マクロのあるブック†

AddTextBox に渡す座標の渡し方†

ブックのシートインデックスを作る†

シートに画像を取り込み、その占めている範囲の右下セルを得る†

いらないシートを消す†

プログラムの同期的な実行†

表示倍率を変える†

ハイパーリンク作成†

印刷設定 右下にページ数を入れる†

印刷範囲の設定†

RangeからA1形式の文字列を得るには†

Worksheets.AddのAfter引数などで渡すのはシート名ではない†

VBAでデータが変わった切れ目で改ページしたい†

印刷改ページを調整する†

CSV形式で保存する†

データのある最後の行を返す†

ゴールシークを実行させる†

ブックを開いてシート毎になにかするサンプル†

VBAプロジェクトをロックする†

VBAファイルのデータ構造†

最新の50件

スクレイピング †

印刷設定右下にページ数を入れる†