エクセルVBAマクロを自動作成する無料アプリです。
例として「シフト表を日付でフィルターし、出勤者を転記する」マクロを作成します。
2つの事例があります。
- 事例1 B10セルで指定した日付の出勤者をA14セルに表示します
- 事例2 C10セルから右方向の複数セルで指定した日付の出勤者を表示します
- 「セルの値の変更で、コードを自動実行する」マクロ
- ChatGPTで修正
- アプリはこちらから↓↓↓↓
事例1 B10セルで指定した日付の出勤者をA14セルに表示します
氏名、表の値が転記されました！
アプリの設定
アプリのトップページ
⇒▼並べ替え・検索・置換・２表比較
⇒【ツール】表の上見出しを検索し、左見出しと値を表示する
ポイント
【シート】
※"セルの"入力値"と、表の"列見出し"の書式は揃えます。
【２】表の左上（A1セル）は空白不可です。
表示されるVBAコード
アプリで作成されたコードを、VBE画面に貼り付ければ、マクロの完成です。
VBAコードを見る
Sub デモ() '表の上見出しを検索し、左見出しと値を表示する
Application.ScreenUpdating = False ' 画面描画を停止
Application.DisplayAlerts = False ' 警告表示を停止'変数の宣言
Dim 対象シート As Worksheet, 入力値 As Range, 表 As Range, 最終行 As Long, 最終列 As Long
Dim 列見出し As Range, 行見出し As Range, 出力行 As Long
'対象シートの設定
Set 対象シート = ThisWorkbook.Sheets("Sheet1")
'エラーメッセージ
If Range("a1") = "" Then
MsgBox "a1セルに値をいれてください"
Exit Sub
End If
'データクリア
Dim データ最終行 As Long, データ最終列 As Long
With 対象シート.Range("a14").CurrentRegion
データ最終行 = Range("a14").Row + .Rows.Count - 2
データ最終列 = Range("a14").Column + .Columns.Count - 1
Range(対象シート.Range("a14"), 対象シート.Cells(データ最終行, データ最終列)).ClearContents
End With
'入力値の設定
Set 入力値 = 対象シート.Range("b10")
'表の範囲の設定
With 対象シート
最終行 = .Range("a1").End(xlDown).Row
最終列 = .Range("a1").End(xlToRight).Column
Set 表 = .Range(.Range("a1"), .Cells(最終行, 最終列))
End With
'出力行の初期化
出力行 = Range("a14").Row
'列見出しを調べるループ処理
For Each 列見出し In 表.Rows(1).Cells
If 列見出し.Value = 入力値.Value Then
'行見出しを調べるループ処理
For Each 行見出し In Range(表.Cells(2, 1), 表.Cells(最終行 - Range("a1").Row + 1, 1))
If Not IsEmpty(Cells(行見出し.Row, 列見出し.Column)) Then
'該当する行見出しと表の値を出力する
対象シート.Cells(出力行, Range("a14").Column) = 行見出し.Value
対象シート.Cells(出力行, Range("a14").Column+1) = Cells(行見出し.Row, 列見出し.Column)
出力行 = 出力行 + 1
End If
Next 行見出し
End If
Next 列見出し
'画面更新と警告メッセージの設定を戻す
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
事例2 C10セルから右方向の複数セルで指定した日付の出勤者を表示します
氏名、表の値が転記されました！
アプリの設定
アプリのトップページ
⇒▼並べ替え・検索・置換・２表比較
⇒【ツール】表の上見出しを検索し、左見出しと値を表示する
ポイント
【シート】
※"セルの"入力値"と、表の"列見出し"の書式は揃えます。
【２】表の左上（A1セル）は空白不可です。
表示されるVBAコード
アプリで作成されたコードを、VBE画面に貼り付ければ、マクロの完成です。
VBAコードを見る
Sub デモ() '表の上見出しを検索し、左見出しと値を表示する
Application.ScreenUpdating = False ' 画面描画を停止
Application.DisplayAlerts = False ' 警告表示を停止' 変数の宣言
Dim 対象シート As Worksheet, 最終行 As Long, 最終列 As Long, 表 As Range, 列見出し As Range
Dim 行見出し As Range, 値 As Range, 列カウント As Long, 行カウント As Long
' 対象シートを設定する
Set 対象シート = ThisWorkbook.Sheets("Sheet1")
'エラーメッセージ
If Range("b2") = "" Then
MsgBox "b2セルに値をいれてください"
Exit Sub
End If
'データクリア
Dim データ最終行 As Long, データ最終列 As Long
With 対象シート.Range("c11").CurrentRegion
データ最終行 = Range("c11").Row + .Rows.Count - 2
データ最終列 = Range("c11").Column + .Columns.Count - 1
Range(対象シート.Range("c11"), 対象シート.Cells(データ最終行, データ最終列)).ClearContents
End With
With 対象シート
' 最終行と最終列を取得する
最終行 = .Range("b2").End(xlDown).Row
最終列 = .Range("b2").End(xlToRight).Column
' 表を定義する
Set 表 = .Range(.Range("b2"), .Cells(最終行, 最終列))
' 列カウントと行カウントを初期化する
列カウント = 0
行カウント = 0
' 検索する値をループする
For Each 値 In Range(.Range("c10"), .Range("c10").End(xlToRight))
' 列見出しをループする
For Each 列見出し In 表.Rows(1).Cells
' 列見出しと値が一致する場合、行見出しを書き出す
If 列見出し.Value = 値.Value Then
For Each 行見出し In Range(表.Cells(2, 1), 表.Cells(最終行 - Range("b2").Row + 1, 1))
If Not IsEmpty(.Cells(行見出し.Row, 列見出し.Column)) Then
.Range("c11").Offset(行カウント, 列カウント).Value = 行見出し.Value
行カウント = 行カウント + 1
End If
Next 行見出し
' 行カウントをリセットする
行カウント = 0
End If
Next 列見出し
' 列カウントをインクリメントする
列カウント = 列カウント + 1
Next 値
End With
'画面更新と警告メッセージの設定を戻す
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
「セルの値の変更で、コードを自動実行する」マクロ
さらに便利な機能を追加します。この例では”A15”セルの値が変更されると上記のマクロを自動実行します。
ChatGPTで修正
あなたが自動化したい内容と事例が少し異なる場合は、無料で使えるマイクロソフトの「BingAIチャット」でコードを修正します。とても簡単です！
