基礎編（1〜20）
1. 「こんにちは」と表示
解答例
Sub Q1_Hello()
MsgBox "こんにちは"
End Sub
2. 変数に代入して表示
解答例
Sub Q2_VarMsg()
Dim n As Long
n = 123
MsgBox "値は " & n
End Sub
3. A1に文字入力
解答例
Sub Q3_WriteCell()
Range("A1").Value = "VBA練習"
End Sub
4. A1〜A5に1〜5を入力
解答例
Sub Q4_Fill1to5()
Dim i As Long
For i = 1 To 5
Cells(i, 1).Value = i
Next i
End Sub
5. A1の値をB1へコピー
解答例
Sub Q5_CopyA1toB1()
Range("B1").Value = Range("A1").Value
End Sub
6. A1+10をB1に
解答例
Sub Q6_Add10()
Range("B1").Value = Val(Range("A1").Value) + 10
End Sub
7. A1:A10 の合計をB1へ
解答例
Sub Q7_SumA1A10()
Dim i As Long, s As Double
For i = 1 To 10
s = s + Val(Cells(i, 1).Value)
Next i
Range("B1").Value = s
End Sub
8. MsgBoxでYes/Noを選択
解答例
Sub Q8_YesNo()
If MsgBox("続けますか？", vbYesNo + vbQuestion) = vbYes Then
MsgBox "Yes"
Else
MsgBox "No"
End If
End Sub
9. InputBoxで名前を聞いて挨拶
解答例
Sub Q9_InputName()
Dim nm As String
nm = InputBox("お名前を入力してください")
If nm <> "" Then MsgBox "こんにちは " & nm & " さん"
End Sub
10. A1〜A5をクリア
解答例
Sub Q10_ClearA1A5()
Range("A1:A5").ClearContents
End Sub
11. A列の最終行をメッセージ表示
解答例
Sub Q11_LastRowMsg()
Dim lr As Long
If WorksheetFunction.CountA(Columns(1)) = 0 Then
lr = 0
Else
lr = Cells(Rows.Count, 1).End(xlUp).Row
End If
MsgBox "A列の最終行: " & lr
End Sub
12. A列を昇順で並べ替え
解答例
Sub Q12_SortAAsc()
With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A1").CurrentRegion.Columns(1), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A1").CurrentRegion
.Header = xlGuess
.Apply
End With
End Sub
13. A列の空白セルを削除（上に詰める）
解答例
Sub Q13_DeleteBlanks()
On Error Resume Next
Columns(1).SpecialCells(xlCellTypeBlanks).Delete xlShiftUp
On Error GoTo 0
End Sub
14. 九九「3の段」をイミディエイト表示
解答例
Sub Q14_Kuku3()
Dim i As Long
For i = 1 To 9
Debug.Print "3 x " & i & " = " & 3 * i
Next i
End Sub
15. A1〜A10に偶数を入力
解答例
Sub Q15_FillEven()
Dim i As Long
For i = 1 To 10
Cells(i, 1).Value = i * 2
Next i
End Sub
16. 値が50未満のセルを黄色
解答例
Sub Q16_ColorUnder50()
Dim c As Range
For Each c In Range("A1:A20")
If c.Value <> "" Then
If Val(c.Value) < 50 Then
c.Interior.Color = vbYellow
Else
c.Interior.Pattern = xlNone
End If
End If
Next c
End Sub
17. A列の「Excel」を「VBA」に置換
解答例
Sub Q17_ReplaceExcelToVBA()
Dim c As Range
For Each c In Range("A1", Cells(Rows.Count, 1).End(xlUp))
c.Value = Replace(CStr(c.Value), "Excel", "VBA")
Next c
End Sub
18. 今日の日付をA1に書き込む
解答例
Sub Q18_TodayToA1()
Range("A1").Value = Date
Range("A1").NumberFormatLocal = "yyyy/m/d"
End Sub
19. A列の最大値をB1に
解答例
Sub Q19_MaxToB1()
Dim lr As Long: lr = Cells(Rows.Count, 1).End(xlUp).Row
If lr = 0 Then Exit Sub
Range("B1").Value = WorksheetFunction.Max(Range("A1:A" & lr))
End Sub
20. A列の最小値をB1に
解答例
Sub Q20_MinToB1()
Dim lr As Long: lr = Cells(Rows.Count, 1).End(xlUp).Row
If lr = 0 Then Exit Sub
Range("B1").Value = WorksheetFunction.Min(Range("A1:A" & lr))
End Sub
実用編（21〜50）
21. Sheet1→Sheet2に値貼り付け
解答例
Sub Q21_CopySheet1To2()
Dim s As Worksheet, d As Worksheet
Set s = ThisWorkbook.Worksheets("Sheet1")
Set d = ThisWorkbook.Worksheets("Sheet2")
d.Range("A1").Resize(s.UsedRange.Rows.Count, s.UsedRange.Columns.Count).Value = s.UsedRange.Value
End Sub
22. 行の高さを一括で20に
解答例
Sub Q22_RowHeight20()
Rows.RowHeight = 20
End Sub
23. 列幅を自動調整
解答例
Sub Q23_AutoFit()
Cells.EntireColumn.AutoFit
End Sub
24. 交互の縞模様で塗り分け
解答例
Sub Q24_BandFill()
Dim r As Long, lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For r = 1 To lr
If r Mod 2 = 0 Then
Rows(r).Interior.ColorIndex = 15
Else
Rows(r).Interior.Pattern = xlNone
End If
Next r
End Sub
25. フォントを太字に
解答例
Sub Q25_Bold()
Cells.Font.Bold = True
End Sub
26. A列を大文字化
解答例
Sub Q26_Upper()
Dim c As Range, lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For Each c In Range("A1:A" & lr)
c.Value = UCase$(CStr(c.Value))
Next c
End Sub
27. A列を小文字化
解答例
Sub Q27_Lower()
Dim c As Range, lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For Each c In Range("A1:A" & lr)
c.Value = LCase$(CStr(c.Value))
Next c
End Sub
28. 「東京都」を見つけた行のB列に「23区」
解答例
Sub Q28_FindTokyo()
Dim f As Range
Set f = Columns(1).Find(What:="東京都", LookIn:=xlValues, LookAt:=xlPart)
If Not f Is Nothing Then
Cells(f.Row, 2).Value = "23区"
Else
MsgBox "見つかりません"
End If
End Sub
29. A列の重複を削除
解答例
Sub Q29_RemoveDuplicates()
Dim lr As Long: lr = Cells(Rows.Count, 1).End(xlUp).Row
If lr > 1 Then Range("A1:A" & lr).RemoveDuplicates Columns:=1, Header:=xlNo
End Sub
30. A列のデータを逆順に
解答例
Sub Q30_ReverseA()
Dim lr As Long: lr = Cells(Rows.Count, 1).End(xlUp).Row
Dim i As Long, tmp As Variant
For i = 1 To lr \ 2
tmp = Cells(i, 1).Value
Cells(i, 1).Value = Cells(lr - i + 1, 1).Value
Cells(lr - i + 1, 1).Value = tmp
Next i
End Sub
31. 同フォルダのSample.xlsxを開く
解答例
Sub Q31_OpenWorkbook()
Dim p As String: p = ThisWorkbook.Path & "\Sample.xlsx"
If Dir(p) <> "" Then
Workbooks.Open p
Else
MsgBox "ファイルが見つかりません: " & p
End If
End Sub
32. このブックのコピーをSavedCopy.xlsxで保存
解答例
Sub Q32_SaveAsCopy()
Dim p As String: p = ThisWorkbook.Path & "\SavedCopy.xlsx"
ThisWorkbook.SaveCopyAs p
MsgBox "保存しました: " & p
End Sub
33. アクティブブックを保存せず閉じる
解答例
Sub Q33_CloseWB_NoSave()
If Workbooks.Count > 0 Then ActiveWorkbook.Close SaveChanges:=False
End Sub
34. すべてのシート名を一覧表示
解答例
Sub Q34_ListSheets()
Dim ws As Worksheet, s As String
For Each ws In ThisWorkbook.Worksheets
s = s & ws.Name & vbCrLf
Next ws
MsgBox s
End Sub
35. 新しいシートを追加
解答例
Sub Q35_AddSheet()
Worksheets.Add
End Sub
36. アクティブシートを削除（確認なし）
解答例
Sub Q36_DeleteActiveSheet()
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
End Sub
37. A列が「完了」の行のみSheet2へコピー
解答例
Sub Q37_FilterCopyDone()
Dim ws As Worksheet, out As Worksheet, rng As Range
Set ws = ActiveSheet
Set out = ThisWorkbook.Worksheets("Sheet2")
Set rng = ws.Range("A1").CurrentRegion
ws.AutoFilterMode = False
rng.AutoFilter Field:=1, Criteria1:="=完了"
out.Cells.Clear
rng.SpecialCells(xlCellTypeVisible).Copy
out.Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
ws.AutoFilterMode = False
End Sub
38. 選択セルの塗りつぶしを黄⇄なしで切替
解答例
Sub Q38_ToggleColorSelected()
Dim c As Range
For Each c In Selection
If c.Interior.ColorIndex = xlNone Or c.Interior.ColorIndex = -4142 Then
c.Interior.Color = vbYellow
Else
c.Interior.Pattern = xlNone
End If
Next c
End Sub
39. 3行目に1行挿入
解答例
Sub Q39_InsertRow3()
Rows(3).Insert
End Sub
40. 5行目を削除
解答例
Sub Q40_DeleteRow5()
Rows(5).Delete
End Sub
41. B列に1列挿入
解答例
Sub Q41_InsertColB()
Columns(2).Insert
End Sub
42. D列を削除
解答例
Sub Q42_DeleteColD()
Columns(4).Delete
End Sub
43. A列に1〜100の連番
解答例
Sub Q43_Fill1to100()
Dim i As Long
For i = 1 To 100
Cells(i, 1).Value = i
Next i
End Sub
44. 偶数行のみ薄色塗り
解答例
Sub Q44_ColorEvenRows()
Dim r As Long
For r = 1 To Rows.Count
If Cells(r, 1).Value = "" And r > 2000 Then Exit For
If r Mod 2 = 0 Then Rows(r).Interior.ColorIndex = 36
Next r
End Sub
45. A1:C1を結合・中央揃え
解答例
Sub Q45_MergeCenter()
With Range("A1:C1")
.Merge
.HorizontalAlignment = xlCenter
.Value = "見出し"
End With
End Sub
46. A1:D? をテーブル化（ヘッダーあり）
解答例
Sub Q46_ConvertToTable()
Dim lr As Long: lr = Cells(Rows.Count, 1).End(xlUp).Row
If lr < 1 Then lr = 1
On Error Resume Next
ActiveSheet.ListObjects(1).Unlist
On Error GoTo 0
ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1:D" & lr), , xlYes).Name = "TblData"
End Sub
47. ピボットテーブルを作成（Cを行、Dを合計）
解答例
Sub Q47_CreatePivot()
Dim wsSrc As Worksheet, wsPv As Worksheet, pc As PivotCache, pt As PivotTable
Set wsSrc = ActiveSheet
Set wsPv = ThisWorkbook.Worksheets("Pivot")
wsPv.Cells.Clear
Dim rng As Range: Set rng = wsSrc.Range("A1").CurrentRegion
Set pc = ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=rng)
Set pt = pc.CreatePivotTable(TableDestination:=wsPv.Range("A3"), TableName:="PT1")
With pt
.PivotFields(3).Orientation = xlRowField
.AddDataField .PivotFields(4), "合計", xlSum
End With
End Sub
48. 四角形の図形を挿入
解答例
Sub Q48_AddShape()
ActiveSheet.Shapes.AddShape msoShapeRectangle, 50, 50, 120, 60
End Sub
49. 先頭の図形に文字を入れる
解答例
Sub Q49_ShapeText()
Dim shp As Shape
If ActiveSheet.Shapes.Count = 0 Then Q48_AddShape
Set shp = ActiveSheet.Shapes(1)
shp.TextFrame2.TextRange.Characters.Text = "サンプル"
End Sub
50. 図形を全削除
解答例
Sub Q50_DeleteShapes()
Dim i As Long
For i = ActiveSheet.Shapes.Count To 1 Step -1
ActiveSheet.Shapes(i).Delete
Next i
End Sub
中級編（51〜80）
51. 配列でA1:A100へ一括出力
解答例
Sub Q51_ArrayWrite()
Dim arr(1 To 100, 1 To 1) As Variant, i As Long
For i = 1 To 100
arr(i, 1) = i
Next i
Range("A1").Resize(100, 1).Value = arr
End Sub
52. Dictionaryでユニーク件数
解答例
Sub Q52_DictUniqueCount()
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim lr As Long: lr = Cells(Rows.Count, 1).End(xlUp).Row
Dim i As Long, v
For i = 1 To lr
v = Cells(i, 1).Value
If Not dict.exists(v) Then dict.Add v, 1
Next i
MsgBox "ユニーク件数: " & dict.Count
End Sub
53. Collectionで要素一覧を表示
解答例
Sub Q53_CollectionList()
Dim col As New Collection, i As Long, s As String
For i = 1 To 5: col.Add "Item" & i: Next i
For i = 1 To col.Count: s = s & col(i) & vbCrLf: Next i
MsgBox s
End Sub
54. 九九表を2次元配列で作成し出力
解答例
Sub Q54_KukuToSheet()
Dim arr(1 To 9, 1 To 9) As Long, r As Long, c As Long
For r = 1 To 9
For c = 1 To 9
arr(r, c) = r * c
Next c
Next r
Range("A1").Resize(9, 9).Value = arr
End Sub
55. 関数プロシージャを呼び出す
解答例
Sub Q55_CallFunction()
MsgBox "3+5=" & AddTwo(3, 5)
End Sub
Function AddTwo(a As Double, b As Double) As Double
AddTwo = a + b
End Function
56. 税込金額UDF
解答例
Function Q56_TaxIncluded(price As Double, Optional rate As Double = 0.1) As Double
Q56_TaxIncluded = WorksheetFunction.Round(price * (1 + rate), 0)
End Function
57. 文字列を逆さにするUDF
解答例
Function Q57_ReverseText(ByVal s As String) As String
Dim i As Long
For i = Len(s) To 1 Step -1
Q57_ReverseText = Q57_ReverseText & Mid$(s, i, 1)
Next i
End Function
58. 西暦→和暦（平成/令和のみ）
解答例
Function Q58_SeirekiToWareki(ByVal y As Long) As String
If y >= 2019 Then
Q58_SeirekiToWareki = "令和" & (y - 2018) & "年"
ElseIf y >= 1989 Then
Q58_SeirekiToWareki = "平成" & (y - 1988) & "年"
Else
Q58_SeirekiToWareki = "対象外"
End If
End Function
59. 0除算のエラーハンドリング
解答例
Sub Q59_ErrorHandling()
On Error GoTo EH
Dim a As Double: a = 10 / 0
MsgBox a
Exit Sub
EH:
MsgBox "エラー: " & Err.Description
End Sub
60. A列が空でない行だけA:DをSheet2へ
解答例
Sub Q60_CopyNonEmptyRows()
Dim ws As Worksheet, out As Worksheet, lr As Long
Set ws = ActiveSheet
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
Set out = ThisWorkbook.Worksheets("Sheet2")
out.Cells.Clear
Dim r As Long, o As Long: o = 1
For r = 1 To lr
If ws.Cells(r, 1).Value <> "" Then
ws.Range(ws.Cells(r, 1), ws.Cells(r, 4)).Copy
out.Cells(o, 1).PasteSpecial xlPasteValues
o = o + 1
End If
Next r
Application.CutCopyMode = False
End Sub
61. A列入力があれば同じ行のBに当日
解答例
Sub Q61_FillDateIfAHasValue()
Dim r As Range
For Each r In Selection
If r.Column = 1 And r.Value <> "" Then
Cells(r.Row, 2).Value = Date
End If
Next r
End Sub
62. ボタン風の図形を作る
解答例
Sub Q62_SetupButtonLikeShape()
Dim shp As Shape
Set shp = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 100, 50, 140, 40)
shp.TextFrame2.TextRange.Characters.Text = "クリックして実行"
End Sub
63. A1にコメント追加
解答例
Sub Q63_AddComment()
With Range("A1")
On Error Resume Next: .Comment.Delete: On Error GoTo 0
.AddComment "メモ: 重要"
End With
End Sub
64. A1のコメント削除
解答例
Sub Q64_DeleteComment()
On Error Resume Next
Range("A1").Comment.Delete
On Error GoTo 0
End Sub
65. 選択範囲をカンマ区切り表示形式に
解答例
Sub Q65_CommaFormat()
Selection.NumberFormatLocal = "#,##0"
End Sub
66. フォントサイズを一括で12ptに
解答例
Sub Q66_FontSize()
Cells.Font.Size = 12
End Sub
67. シート上のセルを全てロック解除
解答例
Sub Q67_UnlockAll()
Cells.Locked = False
End Sub
68. シートを保護（パスワード：pass）
解答例
Sub Q68_ProtectSheet()
ActiveSheet.Protect Password:="pass"
End Sub
69. シート保護を解除（パスワード：pass）
解答例
Sub Q69_UnprotectSheet()
On Error Resume Next
ActiveSheet.Unprotect Password:="pass"
On Error GoTo 0
End Sub
70. 名前付き範囲「MyRange」をA1:C3に設定
解答例
Sub Q70_SetNamedRange()
ThisWorkbook.Names.Add Name:="MyRange", RefersTo:=ActiveSheet.Range("A1:C3")
End Sub
71. 名前付き範囲「MyRange」を削除
解答例
Sub Q71_DeleteNamedRange()
On Error Resume Next
ThisWorkbook.Names("MyRange").Delete
On Error GoTo 0
End Sub
72. 棒グラフを作成
解答例
Sub Q72_CreateChart()
Dim ch As ChartObject
Set ch = ActiveSheet.ChartObjects.Add(Left:=300, Top:=50, Width:=360, Height:=240)
ch.Chart.ChartType = xlColumnClustered
Dim lr As Long: lr = Cells(Rows.Count, 1).End(xlUp).Row
ch.Chart.SetSourceData Source:=Range("A1:B" & IIf(lr = 0, 1, lr))
End Sub
73. グラフタイトルを設定
解答例
Sub Q73_SetChartTitle()
If ActiveSheet.ChartObjects.Count > 0 Then
With ActiveSheet.ChartObjects(1).Chart
.HasTitle = True
.ChartTitle.Text = "売上推移"
End With
End If
End Sub
74. シート上のグラフを全削除
解答例
Sub Q74_DeleteCharts()
Dim i As Long
For i = ActiveSheet.ChartObjects.Count To 1 Step -1
ActiveSheet.ChartObjects(i).Delete
Next i
End Sub
75. 他ブック（Source.xlsx）のA1を取り込む
解答例
Sub Q75_CopyFromAnotherWB()
Dim p As String: p = ThisWorkbook.Path & "\Source.xlsx"
If Dir(p) = "" Then
MsgBox "Source.xlsx が見つかりません": Exit Sub
End If
Dim wb As Workbook
Set wb = Workbooks.Open(p)
ThisWorkbook.Worksheets(1).Range("A1").Value = wb.Worksheets(1).Range("A1").Value
wb.Close SaveChanges:=False
End Sub
76. data.csv（同フォルダ）を開く
解答例
Sub Q76_ReadCSV()
Dim p As String: p = ThisWorkbook.Path & "\data.csv"
If Dir(p) = "" Then MsgBox "data.csv がありません": Exit Sub
Workbooks.OpenText Filename:=p, DataType:=xlDelimited, Comma:=True, Local:=True
End Sub
77. アクティブブックをCSV(UTF-8)で保存
解答例
Sub Q77_WriteCSV()
Dim p As String: p = ThisWorkbook.Path & "\export.csv"
ActiveWorkbook.SaveAs Filename:=p, FileFormat:=xlCSVUTF8, Local:=True
MsgBox "保存: " & p
End Sub
78. 同フォルダのファイル一覧をA列に
解答例
Sub Q78_ListFiles()
Dim p As String: p = ThisWorkbook.Path
Dim f As String, r As Long: r = 1
Cells.Clear
f = Dir(p & "\*.*")
Do While f <> ""
Cells(r, 1).Value = f
r = r + 1
f = Dir
Loop
End Sub
79. check.txt の有無を判定
解答例
Sub Q79_FileExists()
Dim p As String: p = ThisWorkbook.Path & "\check.txt"
If Dir(p) <> "" Then
MsgBox "存在します"
Else
MsgBox "ありません"
End If
End Sub
80. 空のテキストファイルを作る
解答例
Sub Q80_CreateTextFile()
Dim p As String: p = ThisWorkbook.Path & "\newfile.txt"
Dim ff As Integer: ff = FreeFile
Open p For Output As #ff
Print #ff, "Hello"
Close #ff
MsgBox "作成: " & p
End Sub
応用編（81〜100）
81. 郵便番号→住所（簡易辞書）
解答例
Sub Q81_ZipToAddress()
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.Add "1000001", "東京都千代田区千代田"
dict.Add "1600022", "東京都新宿区新宿"
Dim r As Range
For Each r In Range("A1", Cells(Rows.Count, 1).End(xlUp))
If dict.exists(CStr(r.Value)) Then
Cells(r.Row, 2).Value = dict(CStr(r.Value))
End If
Next r
End Sub
82. 郵便番号を日本郵便サイトで検索（既定ブラウザ）
解答例
Sub Q82_OpenZipWeb()
Dim zip As String: zip = InputBox("郵便番号（ハイフン無し）")
If zip <> "" Then
Dim url As String: url = "https://www.post.japanpost.jp/cgi-zip/zipcode.php?zip=" & zip
ThisWorkbook.FollowHyperlink url
End If
End Sub
83. Outlookでメール送信（遅延バインディング）
解答例
Sub Q83_SendMail()
On Error GoTo EH
Dim ol As Object, mail As Object
Set ol = CreateObject("Outlook.Application")
Set mail = ol.CreateItem(0)
With mail
.To = "someone@example.com"
.Subject = "テスト送信"
.Body = "VBAから送信しました。"
'.Display
.Send
End With
MsgBox "送信しました"
Exit Sub
EH:
MsgBox "Outlook送信に失敗: " & Err.Description
End Sub
84. Outlook受信箱の件名上位10件を表示
解答例
Sub Q84_ReadInbox()
On Error GoTo EH
Dim ol As Object, ns As Object, inbox As Object, itm As Object, i As Long, s As String
Set ol = CreateObject("Outlook.Application")
Set ns = ol.GetNamespace("MAPI")
Set inbox = ns.GetDefaultFolder(6) 'olFolderInbox
For i = 1 To Application.WorksheetFunction.Min(10, inbox.Items.Count)
Set itm = inbox.Items(i)
s = s & itm.Subject & vbCrLf
Next i
MsgBox s
Exit Sub
EH:
MsgBox "Outlook受信箱の取得に失敗: " & Err.Description
End Sub
85. Wordに表として貼り付け
解答例
Sub Q85_ExportToWordTable()
On Error GoTo EH
Dim wd As Object, doc As Object, rng As Range
Set rng = Range("A1").CurrentRegion
Set wd = CreateObject("Word.Application")
Set doc = wd.Documents.Add
wd.Visible = True
rng.Copy
doc.Content.PasteExcelTable False, False, False
Exit Sub
EH:
MsgBox "Word連携に失敗: " & Err.Description
End Sub
86. PowerPointにスライド追加して表を貼付
解答例
Sub Q86_ExportToPPT()
On Error GoTo EH
Dim pp As Object, pres As Object, sl As Object
Set pp = CreateObject("PowerPoint.Application")
Set pres = pp.Presentations.Add
pres.Slides.Add 1, 12 'ppLayoutBlank
pp.Visible = True
Range("A1").CurrentRegion.Copy
Set sl = pres.Slides(1)
sl.Shapes.Paste
Exit Sub
EH:
MsgBox "PowerPoint連携に失敗: " & Err.Description
End Sub
87. Access(ACE OLEDB)に接続してSELECT
解答例
Sub Q87_AccessSelect()
On Error GoTo EH
Dim cn As Object, rs As Object, p As String
p = ThisWorkbook.Path & "\sample.accdb"
If Dir(p) = "" Then MsgBox "sample.accdb がありません": Exit Sub
Set cn = CreateObject("ADODB.Connection")
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & p & ";"
Set rs = cn.Execute("SELECT TOP 10 * FROM Table1")
Range("A1").CopyFromRecordset rs
rs.Close: cn.Close
Exit Sub
EH:
MsgBox "Access接続に失敗: " & Err.Description
End Sub
88. SQL的条件をAutoFilterで模倣（B列>=100）
解答例
Sub Q88_SQLLikeFilter()
Dim rng As Range: Set rng = ActiveSheet.Range("A1").CurrentRegion
rng.AutoFilter Field:=2, Criteria1:=">=100"
End Sub
89. JSON文字列（簡易）を解析してA:Bに展開
解答例
Sub Q89_ParseJSON_Simple()
Dim s As String: s = "{""name"":""Taro"",""age"":20}"
s = Replace(Replace(s, "{", ""), "}", "")
Dim arr As Variant: arr = Split(s, ",")
Dim i As Long, k As String, v As String
Cells.Clear
For i = 0 To UBound(arr)
k = Split(arr(i), ":")(0)
v = Split(arr(i), ":")(1)
k = Replace(Replace(k, """", ""), " ", "")
v = Replace(Replace(v, """", ""), " ", "")
Cells(i + 1, 1).Value = k
Cells(i + 1, 2).Value = v
Next i
End Sub
90. XMLファイルを読み込んで要素名と値を出力
解答例
Sub Q90_ParseXML()
On Error GoTo EH
Dim p As String: p = ThisWorkbook.Path & "\sample.xml"
If Dir(p) = "" Then MsgBox "sample.xml がありません": Exit Sub
Dim x As Object: Set x = CreateObject("MSXML2.DOMDocument")
x.async = False: x.Load p
If x.parseError.ErrorCode <> 0 Then MsgBox "XMLエラー": Exit Sub
Dim n As Object, r As Long: r = 1
For Each n In x.DocumentElement.ChildNodes
Cells(r, 1).Value = n.NodeName
Cells(r, 2).Value = n.Text
r = r + 1
Next n
Exit Sub
EH:
MsgBox "XML解析に失敗: " & Err.Description
End Sub
91. WinHttpでHTTP GET（GitHub API）
解答例
Sub Q91_HTTPGet()
On Error GoTo EH
Dim http As Object: Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
http.Open "GET", "https://api.github.com", False
http.Send
Cells(1, 1).Value = http.Status & " " & http.StatusText
Cells(2, 1).Value = Left(http.ResponseText, 500)
Exit Sub
EH:
MsgBox "HTTPアクセス失敗: " & Err.Description
End Sub
92. QueryTablesでWebテーブル取得（例URL）
解答例
Sub Q92_WebQuery()
On Error GoTo EH
Dim qt As QueryTable
Cells.Clear
Set qt = ActiveSheet.QueryTables.Add(Connection:="URL;https://example.com", Destination:=Range("A1"))
qt.Refresh BackgroundQuery:=False
Exit Sub
EH:
MsgBox "Web取得に失敗: " & Err.Description
End Sub
93. シート上の最初のグラフをPNG保存
解答例
Sub Q93_ExportChartAsImage()
If ActiveSheet.ChartObjects.Count = 0 Then
MsgBox "グラフがありません": Exit Sub
End If
Dim p As String: p = ThisWorkbook.Path & "\chart.png"
ActiveSheet.ChartObjects(1).Chart.Export Filename:=p, FilterName:="PNG"
MsgBox "保存: " & p
End Sub
94. シートをPDFで保存
解答例
Sub Q94_ExportSheetPDF()
Dim p As String: p = ThisWorkbook.Path & "\sheet.pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=p
MsgBox "保存: " & p
End Sub
95. PDF結合（外部ツール前提のサンプル）
解答例
Sub Q95_PDFMerge_Sample()
MsgBox "pdftk など外部ツールが必要です。"
End Sub
96. 起動時自動処理のデモ（ThisWorkbook推奨）
解答例
Sub Q96_SimulateWorkbookOpen()
MsgBox "起動時処理のサンプル（実際はThisWorkbookに記述）"
End Sub
97. シートActivateイベントのデモ
解答例
Sub Q97_SimulateWorksheetActivate()
MsgBox "シートActivateイベントのサンプル（実際はシートモジュール）"
End Sub
98. ユーザーフォーム相当の簡易入力（代替）
解答例
Sub Q98_CreateUserFormRuntime()
MsgBox "フォーム代替: 入力をここで受けます。"
End Sub
99. 入力内容（商品名・数量）をシート末尾へ
解答例
Sub Q99_InputToSheet()
Dim a As String, b As String
a = InputBox("商品名")
b = InputBox("数量")
If a <> "" Then
Dim lr As Long: lr = Cells(Rows.Count, 1).End(xlUp).Row + 1
If lr = 1 Then Range("A1:C1").Value = Array("商品名", "数量", "日時"): lr = 2
Cells(lr, 1).Value = a
Cells(lr, 2).Value = b
Cells(lr, 3).Value = Now
End If
End Sub
100. 在庫管理ミニアプリ（追加・検索・削除）
解答例
Sub Q100_InventoryMiniApp()
Dim mode As String: mode = InputBox("操作を選択: add / find / del")
Dim id As String: id = InputBox("商品ID")
If id = "" Then Exit Sub
Dim lr As Long: lr = Cells(Rows.Count, 1).End(xlUp).Row
Dim r As Long, found As Long: found = 0
If lr < 1 Then
Range("A1:C1").Value = Array("商品ID", "商品名", "数量")
lr = 1
End If
For r = 2 To lr
If Cells(r, 1).Value = id Then
found = r: Exit For
End If
Next r
Select Case LCase$(mode)
Case "add"
Dim name As String, qty As Long
name = InputBox("商品名")
qty = Val(InputBox("数量"))
If found = 0 Then
Cells(lr + 1, 1).Resize(1, 3).Value = Array(id, name, qty)
Else
Cells(found, 2).Value = name
Cells(found, 3).Value = qty
End If
MsgBox "登録しました"
Case "find"
If found = 0 Then
MsgBox "見つかりません"
Else
MsgBox "ID:" & Cells(found, 1).Value & " 名称:" & Cells(found, 2).Value & " 数量:" & Cells(found, 3).Value
End If
Case "del"
If found = 0 Then
MsgBox "見つかりません"
Else
Rows(found).Delete
MsgBox "削除しました"
End If
Case Else
MsgBox "不明な操作です"
End Select
End Sub