小技
- プログラマーのネタ帳に書くには少し行数が多いコードを集めました
CONTENTS
2.行の高さの取得と設定
3.不要行の削除
Excelのシート上行が存在していないように見えても実はデータが存在しているように
扱われるエリアがあります。そのような行も含めて削除します。
4.Workbooks変数の使用
5.連結用行挿入
6.フィルターで絞った範囲の処理
1.列幅と取得と設定
- Sheet2の1列目から20列目までの列幅を取得してSheet3に設定する事例です
Sub 列幅の取得とコピー()
Dim i As Long
Dim habaTBL(20) As Double
For i = 1 To 20
habaTBL(i - 1) = Sheets("Sheet2").Columns(i).ColumnWidth
Next
For i = 1 To 20
Sheets("sheet3").Columns(i).ColumnWidth = habaTBL(i - 1)
Next
End Sub
2.行の高さの取得と設定
- Sheet2の1行目から20行目までの行の高さをを取得してSheet3に設定する事例です
Sub 行高さ取得とコピー()
Dim i As Long
Dim takasaTBL(20) As Double
For i = 1 To 20
takasaTBL(i - 1) = Sheets("Sheet2").Rows(i).RowHeight
Next
For i = 1 To 20
Sheets("sheet3").Rows(i).RowHeight = takasaTBL(i - 1)
Next
End Sub
3.不要行の削除
'特定条件の行を削除する（高速）
' この処理は列Bが１の行を高速で削除します
'手順として①行に連番をつける②対象行をクリアｰする
' ③空白領域を削除する の３つの手順となります
Sub A_008()
Dim i, Max1, Max2 As Long
Application.ScreenUpdating = False 'ディスプレイ出力抑止
Application.Calculation = xlCalculationManual '関数自動計算抑止
Max1 = Cells(Rows.Count, "C").End(xlUp).Row
'連番記入
i = 2
For i = 2 To Max1
Cells(i, "Z") = i
Next
'不要データ削除
For i = 2 To Max1
If Cells(i, "B") = 1 Then
Range(Cells(i, "A"), Cells(i, "Z")).Clear
End If
Next
'連番でソート
Range("A1:Z" & Max1).Sort Key1:=Range("Z1"), Order1:=xlAscending, _
Header:=xlYes
'不要エリア削除
Columns("Z").Clear
Max1 = Max1 + 1
Max2 = Cells.SpecialCells(xlCellTypeLastCell).Row
Range(Max1 & ":" & Max2).EntireRow.Delete
Application.ScreenUpdating = True 'ディスプレイ出力再開
Application.Calculation = xlCalculationAutomatic '関数自動計算再開
End Sub
4.Workbooks変数の使用
'参照ファイルのオープンとクローズ(ワークシート変数の活用）
'ファイルはオープンするときはディレクトリを全て記述する必要がありますが、'クローズしたり再selectするときはファイ'名だけ（ここでは”File_A.xlsx"）を'指定する必要があります。この二重定義はファイル名を外部定義する場合、オペレータ入力
'する場合面倒です。そこで下記のようにワークシート変数を使います。
sub test111()
Dim fname As Strings
Dim xlBook As Workbook
fname = "D:\2021\File_A.xlsx"
Application.DisplayAlerts = False
If Dir(fname) <> "" Then
Set xlBook = Workbooks.Open(fname)
Else
MsgBox fname & " が存在しません"
Exit Sub
End If
'***** 一連の処理 ********
*******************************
*******************************
xlBook.close
’または Workbooks("File_A.xlsx").close (fname.close あるいは Workbooks(fname).closeでは文法エラーとなる）
Application.DisplayAlerts = True
end sub
5.連結用行挿入
1件のデータに対して複数行のデータが連結可能な場合 元のデータを行挿入して全ての連結先を
書き込み可能にしておく必要があります
社員に対する家族、製品に対する部品、注文番号に対する複数の明細など編集時に使用します
下記の例はあらかじめA列に連結する相手の行数をセットしてあるという想定です。
連結(JOIN)操作をExcelマクロで作成するのはむつかしいのでMicrosoft365が使えるのであれば、PowerQueery
の使用も検討したほうが良いと思います。
sub 連結用行挿入()
'A列の数に従って行を挿入する
Dim MaxRow, i, j, n As Long
MaxRow = Cells(Rows.Count, 1).End(xlUp).Row
i = 2
Do While i <= MaxRow
If Cells(i, "A") > 1 Then
n = Cells(i, "A")
j = n + i - 1 '行挿入する最後の行
i = i + 1 '行挿入する最初の行
Rows(i & ":" & j).Insert
MaxRow = MaxRow + n - 1 '挿入した分最大行を増やす
i = i + n - 1 '挿入した分現在行を加算する 3行前で
'すでに1加算しているのでここで引く
Else
i =i + 1
End If
Loop
end sub
6.フィルターで絞った範囲の処理
フィルターでデータの行を絞り、その絞った各行について処理をする方法です。実行後82がメッセージボックスに表示されます
Sub A01フィルター
Dim N1 As String
Dim R As Range
Dim SU As Long
N1 = "山田"
Range("A1").AutoFilter 2, N1 ’2列目を"山田"で絞り込む
With Range("A1").CurrentRegion.Offset(1, 0) ’2行目以降を処理対象とする
’見えている範囲の全ての行（－1行）それぞれに対して処理を実行する
For Each R In .Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Rows
SU = SU + Cells(R.Row, 3)
Next R
MsgBox SU
End With
End Sub
7.祭日の一覧を総理府のHPからダウンロードする
内閣府HPから祭日のCSVファイルを取り込んで現在Selectされているシートに貼り付けます。
このCSVファイル1955年以降の祭日が記載されているので、過去のものは削除しています。
一度ダウンロードするのでそのディレクトリは自身で設定願います。
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long _
) As Long
Sub 祭日取得()
Dim RST As Long
Dim 内閣府URL, MyPath As String
Dim intFree, col, row, Maxrow As Long
Dim strRec As String
Dim strSplit() As String
MyPath = "C:\Users\xxxxx\Downloads\祝日一覧.csv" '自分のダウンロードディレクトリまたは
'チームで共有できるOneDriveのディレクトリ
内閣府URL = "https://www8.cao.go.jp/chosei/shukujitsu/syukujitsu.csv"
RST = URLDownloadToFile(0, 内閣府URL, MyPath, 0, 0)
If RST <> 0 Then
MsgBox "ファイルをダウンロードできませんでした"
Exit Sub
End if
intFree = FreeFile '空番号を取得
Open MyPath For Input As #intFree 'CSVファィルをオープン
row = 0
Do Until EOF(intFree)
Line Input #intFree, strRec '1行読み込み
row = row + 1
strSplit = Split(strRec, ",") ' split関数でカンマ区切りで配列へ
For col = 0 To UBound(strSplit) '配列各要素をセルの左から落とし込む
Cells(row, col + 1) = strSplit(col)
Next
Loop
Close #intFree
Maxrow = Cells(Rows.Count, "A").End(xlUp).row 'ダウンロードした表の最大行を求める
row = WorksheetFunction.Match(Date * 1, Range("A1:A" & Maxrow), 1) '今日以前の祭日の位置を見つける
Range("A2:B" & row).Clear '過去の祭日をクリアする
'日付でソートする
Range("A1:B" & Maxrow).Sort Key1:=Range("A1"), Order1:=xlAscending, _
Header:=xlYes
End Sub
8.OUTLOOKを操作する
VBAでメール操作をすることは、下記理由でで重要さを増しています。（2023/5段階）
ExcelVBAはクラウド環境下(Teams)で使用するとなると大きく制約を受けます。そもそもTeams上のExcelでマクロは動きません。またクラウド上のExcelファイルを開くことは場合によっては可能ですが、更新することはかなりむつかしいです。
もしそのファイルが共有されていなければ更新が可能な場合もありますが、共有されていた場合、Teams上で更新された内容をVBAが壊してしまうという現象が発生します。また、Excelファイルが共有されているかどうかはローカルのVBAからは状態を把握することはできません。
そこで、クラウド上のファイルを開いたら、内容をローカルにコピーして、データ処理後、クラウド上のワークファイル
にUPして、更新処理はPowerAutomateに任せるなどの方法が考えられます（それも難易度が高いのですが）。その場合『自動化したクラウドフロー』を起動するのにメールをトリガーがとするのが非常に有効なわけです。
逆に言うと現在のところPowerAutomateは『スケジュール済クラウドフロー』以外の『自動化』に関しては（個人的には）
不十分であると考えています。具体的には開いたファイルが閉じるタイミング、特定の列がアップデートされたタイミング
などでトリガーを引くのがむつかしいのです。ですから、VBAで一連の処理、またはExcelを閉じるタイミングでメールを飛ばして、（強引に）PowerAutomateのトリガーを引くわけです。
現在のところTeams上のExcelを（まとめて）更新する方法はPowerAutomateかOffice Scriptしかないと考えています。
（1）OUTLOOKが開いていなければ、OUTLOOKを起動する
メールを送るのにOUTLOOKが開いている必要は必ずしも必要ではありませんが、VBAで勝手にメールを送って
オペレータもそれに気づかないというのは情報管理上問題があると思うのですが、気にしない方は必要ありません。
Sub outlook_open()
Dim O_App As Outlook.Application
Dim myNameSpace As Outlook.Namespace
Dim myFolder As Outlook.Folder
On Error GoTo 0
Set O_App = GetObject(, "Outlook.Application") 'OUTOOKが開いているか調べる
On Error GoTo 0
If O_App Is Nothing Then
Set O_App = CreateObject("Outlook.Application") 'OUTLOOKを開く（準備）
Set myNameSpace = O_App.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(6) 'OUTLOOKのあるフォルダー olFolderInbox=6 '
myFolder.Display 'フォルダーを開く（OUTOLOOK起動）
Else
End If
End Sub
（2）メールを送信する（OUTLOOKが起動していなくても可、勝手に起動して終わる）
Sub 送信1()
Dim tns As Namespace
Dim O_App As Outlook.Application
Dim myMail As Outlook.MailItem
On Error GoTo 0
Set O_App = CreateObject("Outlook.Application")
On Error GoTo 0
'Outlookメール送信用の変数設定
Set myMail = O_App.CreateItem(olMailItem)
With myMail
.To = "XXXXXX@XXXX.XXX.ne.jp" 'メール宛先
.Subject = "testメールの件名" 'メール件名
.Body = "testメール本文" 'メール本文
.BodyFormat = olFormatPlain 'メールの形式
End With
myMail.Send
End Sub
9.pdfファイルを出力する
現在のシートだけ出力するか①、Bookの全ページを出力するか②選択願います
Sub Test11A()
Dim i, MaxRow As Long
Dim MyDir, sh_name, book_name, NextexPath As String
sh_name = ActiveSheet.Name '①出力するpdf名に適宜変える
book_name = ActiveWorkbook.Name '②出力するpdf名に適宜変える
'① 現在のシートだけ出力
NextexPath = MyDir & "\" & sh_name & ".pdf"
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=sh_name
'② 現在Bookのシートを全て出力
NextexPath = MyDir & "\" & book_name & ".pdf"
ThisWorkbook.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=book_name
End Sub
10.図形（Shape)やテキストボックスを操作する
1.図形を作成する
下記のモジュールはテキストボックス、四角、角丸四角をシートに貼り付けたプロシージャです
数字が4つ続いている場所は、左からの位置、上からの位置、幅、高さを示しています。
変数を用いても構いません。
(1)単純に図形を作成する
Sub a_test1()
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 80, 90, 70, 50).Select
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 170, 90, 70, 50).Select
ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 260, 90, 70, 50).Select
End Sub
(2)図形に色を付ける
ここでは図形の背景色を変える方法を紹介します。
いずれも一度作成した後色を付けています。
画面上優先的に選択する色と同調するときは"ObjectThemeColor"を使いますがRGBで設定したほうが後のメンテナンス
は楽だと思います。
Sub a_test2()
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 80, 90, 70, 50).Select
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 170, 90, 70, 50).Select
Selection.ShapeRange.Fill.ForeColor.ObjectThemeColor = msoThemeColorAccent2
ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 260, 90, 70, 50).Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 0)
End Sub
(3)図形に名前を付けて作成する
図形に名前を付けて作成するには下記のような書き方をします。
図形の名前はページレイアウトリボン⇒オブジェクトの選択と表示を選択することで
シートの右側に表示されます。この名前を使ってオブジェクトのプロパディをコントロールすることもできますが
注意すべきことが２点あります
①表示されている名称とVBAで操作できる名称が違う（VBAではデフォルトの名称はアルファベット表記）
②（VBAで名称設定したとき）同一名称でも登録されてしまいます。
Sub a_test3()
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 170, 90, 70, 50).Select
Selection.Name = "squere1"
(4)図形の中に文字を記入する
Sub a_test4()
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 170, 90, 70, 50).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "名称1"
End Sub
2.図形を消去する
(1)シート内の図形をすべて消去する
Sub d_test1()
ActiveSheet.DrawingObjects.Delete
End Sub
(2)選択した図形のみを削除する
Sub d_test2()
On Error Resume Next '図形が選択されていなかった場合のエラー回避
Selection.ShapeRange.Delete
End Sub
(3)指定した範囲の図形のみを削除する
指定した範囲に図形がかかっていれば、削除します。
Sub d_test3()
Dim myRng As Range
Dim shp As Object
With ActiveSheet
Set myRng = .Range("B5:D9")
For Each shp In .Shapes
If Not Intersect(.Range(shp.TopLeftCell, shp.BottomRightCell), myRng) Is Nothing Then
shp.Delete
End If
Next
End With
End Sub
(3)指定した形の図形のみを削除する
Sub d_test4()
Dim shp As Object
With ActiveSheet
For Each shp In .Shapes
If shp.Name Like "Rectangle*" Then
shp.Delete
End If
Next
End With
End Sub
(4)指定した番号の図形のみを削除する
シート上の各図形には、1から始まるユニークな番号が割り当てられています。
この取得方法は以下の通りです。今回は選択した図形の番号を表示します。
何も選択しなかった場合のエラーを回避するために少し複雑になっています。
Sub ｍ_test5() '連番の取得
Dim a As Long
Dim shp As Object
With ActiveSheet
On Error GoTo err1 '下の行は ShaoeRange.Count = 0 の時にエラーになります
If Selection.ShapeRange.Count > 0 Then '1以上選択されている場合
For Each shp In Selection.ShapeRange
a = shp.ZOrderPosition
MsgBox a
Next
err1:
End If
End With
End Sub
For each を使うと途中で連番が書き換わってしまいますので
連番 1 ～ Shapes.Countの範囲内でループさせます
Sub d_test6() ’連番での削除
Dim a As Long
With ActiveSheet
For a = 1 To .Shapes.Count
If a = 2 Then
.Shapes(a).Select
Selection.Delete
End If
Next
End With
End Sub