Excel VBA 52 Excelで選択したセルの罫線を自動生成

選択したセルの罫線（格子+太い外枠）と1行目のセルの塗りつぶしを自動生成します。

Sub SetGridWithBoldBorderAndFill()

Dim rng As Range

Dim border As Variant

Dim firstRow As Range

Dim colorDialog As Object

Dim chosenColor As Long

' 選択範囲を取得

Set rng = Selection

' 格子状の罫線を設定

rng.Borders(xlInsideHorizontal).LineStyle = xlContinuous

rng.Borders(xlInsideHorizontal).Weight = xlThin

rng.Borders(xlInsideVertical).LineStyle = xlContinuous

rng.Borders(xlInsideVertical).Weight = xlThin

' 外枠を太枠に設定

For Each border In Array(xlEdgeLeft, xlEdgeRight, _

xlEdgeTop, xlEdgeBottom)

With rng.Borders(border)

.LineStyle = xlContinuous

.Weight = xlThick

End With

Next border

' 最初の行を取得

Set firstRow = rng.Rows(1)

' カラーダイアログを表示し、ユーザーに色を選択させる

Set colorDialog = Application.Dialogs(xlDialogEditColor)

If colorDialog.Show(1) Then

chosenColor = ActiveWorkbook.Colors(1)

firstRow.Interior.Color = chosenColor

End If

End Sub

データの有無に関係なく・・・

任意のセルを選択して実行すると・・・

選択した範囲の一行目の塗りつぶしの色を要求してくるので設定すれば・・・

全体は格子、太線の外枠で選択した範囲の一行目の塗りつぶしが完了します。

Excel VBA 51 単純処理でもデータ量が多い場合もVBA

単純でも大量処理の場合はVBAで対処した方が賢明です。

データの全体です。

データはA1:L31まで入力されていて

C2:L31までの30名の10科目のテスト結果です。

作成するデータは・・・

M列に合計点

N列に平均点

O列に合否

85点以上はA合格、75点以上はB合格、65点以上はB合格。それ以外は不合格。

を入力する簡単な計算です。サンプルは30名分ですが、もし1000名文分と言った場合はフィルよりも今回のVBAを￥のセル指定を変更して活用すれば一気に処理出来ます。

Sub 計算式を入力し右揃え()

Dim ws As Worksheet

Dim i As Integer

' アクティブシートを設定（または特定のシートを指定）

Set ws = ActiveSheet

' 2行目から31行目まで繰り返し処理

For i = 2 To 31

' M列（合計）

ws.Cells(i, 13).Formula = _

"=SUM(C" & i & ":L" & i & ")"

ws.Cells(i, 13).HorizontalAlignment = xlRight ' 右揃え

' N列（平均）

ws.Cells(i, 14).Formula = _

"=AVERAGE(C" & i & ":L" & i & ")"

ws.Cells(i, 14).HorizontalAlignment = xlRight ' 右揃え

' O列（評価）

ws.Cells(i, 15).Formula = "=IF(N" & i _

& ">=85,""A合格"",IF(N" & i & ">=75,""B合格"",IF(N" & i _

& ">=65,""C合格"",""不合格"")))"

ws.Cells(i, 15).HorizontalAlignment = xlRight ' 右揃え

Next i

' メッセージ表示（オプション）

MsgBox "数式を31行目まで入力し、右揃えにしました！", _

vbInformation

End Sub

というコトで上は処理結果です。

Excel VBA 50 Exccelで指定月のカレンダーを作成

Exccelで指定した年月のカレンダーを作成します。

Sub CreateCalendarFromUserInput()

Dim ws As Worksheet

Dim yearInput As Integer, monthInput As Integer

Dim startDate As Date, endDate As Date

Dim row As Integer, col As Integer, dayCounter As Integer

' シートを取得（カレンダーシートを作成・クリア）

Set ws = ThisWorkbook.Sheets("Sheet1")

' 必要に応じてシート名を変更

ws.Cells.Clear ' 既存のカレンダーをクリア

' ユーザーに年と月を入力してもらう

yearInput = InputBox("西暦を入力してください（例：2025）", _

"年の入力")

If yearInput < 1900 Or yearInput > 2100 Then

MsgBox "有効な年（1900?2100）を入力してください。", _

vbExclamation

Exit Sub

End If

monthInput = InputBox("月を入力してください（1?12）", _

"月の入力")

If monthInput < 1 Or monthInput > 12 Then

MsgBox "有効な月（1?12）を入力してください。", _

vbExclamation

Exit Sub

End If

' 開始日と終了日を設定

startDate = DateSerial(yearInput, monthInput, 1)

endDate = DateSerial(yearInput, monthInput + 1, 0)

' ヘッダーにタイトル

ws.Cells(1, 1).Value = yearInput & "年 " & monthInput & "月"

ws.Cells(1, 1).Font.Size = 14

ws.Cells(1, 1).Font.Bold = True

ws.Range("A1:G1").Merge

ws.Cells(1, 1).HorizontalAlignment = xlCenter

' 曜日ヘッダー

Dim daysOfWeek As Variant

daysOfWeek = Array("日", "月", "火", "水", "木", "金", "土")

' 曜日を2行目に設定

For col = 0 To 6

ws.Cells(2, col + 1).Value = daysOfWeek(col)

ws.Cells(2, col + 1).Font.Bold = True

ws.Cells(2, col + 1).HorizontalAlignment = xlCenter

ws.Cells(2, col + 1).Interior.Color = RGB(200, 200, 250)

' ヘッダーの背景色

Next col

' 日付を埋める

row = 3

col = weekDay(startDate, vbSunday) - 1

' 週の最初の曜日（0:日曜, 6:土曜）

For dayCounter = 1 To Day(endDate)

ws.Cells(row, col + 1).Value = dayCounter

ws.Cells(row, col + 1).HorizontalAlignment = xlCenter

col = col + 1

If col > 6 Then

col = 0

row = row + 1

End If

Next dayCounter

' セルのサイズ調整

ws.Cells.EntireColumn.AutoFit

ws.Range("A2:G2").Interior.Color = RGB(200, 200, 250)

' ヘッダー色

ws.Range("A3:G" & row).Borders.LineStyle = xlContinuous

' 罫線

MsgBox "カレンダーが作成されました！", vbInformation

End Sub

実行したら年月を入力すれば・・・

A2〜G8を利用してカレンダーを表示します。

Excel VBA 49 ExccelでA2とA2セルの色を指定段階の色相グラデに

ExccelでA2とA2セルの色から指定した段階の色相グラデ—ションを作成します。

Sub ApplyHueGradientToColumnB()

Dim ws As Worksheet

Dim startColor As Long, endColor As Long

Dim steps As Integer, i As Integer

Dim startHue As Single, endHue As Single

Dim startSaturation As Single, startBrightness As Single

Dim endSaturation As Single, endBrightness As Single

Dim h As Single, s As Single, b As Single

Set ws = ActiveSheet

startColor = ws.Range("A1").Interior.Color

endColor = ws.Range("A2").Interior.Color

steps = Application._

        InputBox("ステップ数を入力してください:", Type:=1)

' RGBからHSBに変換

RGBtoHSB startColor, startHue, startSaturation, startBrightness

RGBtoHSB endColor, endHue, endSaturation, endBrightness

' グラデーションを適用

For i = 0 To steps

h = startHue + (endHue - startHue) * i / steps

s = startSaturation + _

            (endSaturation - startSaturation) * i / steps

b = startBrightness + _

            (endBrightness - startBrightness) * i / steps

ws.Cells(i + 3, 2).Interior.Color = HSBtoRGB(h, s, b) ' B列に適用

Next i

End Sub

' RGB を HSB に変換

Sub RGBtoHSB(ByVal rgbColor As Long, _

    ByRef h As Single, ByRef s As Single, ByRef b As Single)

Dim r As Single, g As Single, bl As Single

Dim minVal As Single, maxVal As Single, delta As Single

r = (rgbColor Mod 256) / 255

g = ((rgbColor ¥ 256) Mod 256) / 255

bl = (rgbColor ¥ 65536) / 255

minVal = WorksheetFunction.Min(r, g, bl)

maxVal = WorksheetFunction.Max(r, g, bl)

delta = maxVal - minVal

b = maxVal ' 明度

If delta = 0 Then

h = 0

s = 0

Else

s = delta / maxVal ' 彩度

If maxVal = r Then

h = (g - bl) / delta

ElseIf maxVal = g Then

h = 2 + (bl - r) / delta

Else

h = 4 + (r - g) / delta

End If

h = h * 60

If h < 0 Then h = h + 360

End If

End Sub

' HSB を RGB に変換

Function HSBtoRGB(ByVal h As Single, _

    ByVal s As Single, ByVal b As Single) As Long

Dim r As Single, g As Single, bl As Single

Dim i As Integer, f As Single, p As Single, q As Single, t As Single

If s = 0 Then

r = b: g = b: bl = b

Else

h = h / 60

i = Int(h)

f = h - i

p = b * (1 - s)

q = b * (1 - s * f)

t = b * (1 - s * (1 - f))

Select Case i Mod 6

Case 0: r = b: g = t: bl = p

Case 1: r = q: g = b: bl = p

Case 2: r = p: g = b: bl = t

Case 3: r = p: g = q: bl = b

Case 4: r = t: g = p: bl = b

Case 5: r = b: g = p: bl = q

End Select

End If

HSBtoRGB = RGB(Int(r * 255), Int(g * 255), Int(bl * 255))

End Function

A1とA2セルに基準となる塗りを行い、VBAを実行すると段階数を入力するパレットが表示されるので任意入力すれば・・・

指定段階段階の基準の色の間となる段階の塗りをB列に表示します。

Excel VBA 48 Excelで選択したエリアを市松模様選択

Excelで選択したエリアを一行おきに選択し、色を設定します。

デフォルト環境で設定するのが面倒くさいので作成した一行版の市松模様版です。

Excel VBA 47　Excelで選択したエリアを一列おきに選択 2025/07/16

Excel VBA 46　Excelで選択したエリアを一行おきに選択 2025/06/25

Sub SelectCheckerboardPattern()

Dim rng As Range

Dim cell As Range

Dim newSelection As Range

Dim rowIndex As Integer, colIndex As Integer

' 選択範囲を取得

On Error Resume Next

Set rng = Selection

On Error GoTo 0

' 範囲が選択されていない場合、エラーを表示

If rng Is Nothing Then

MsgBox "セル範囲を選択してください。", _

vbExclamation, "エラー"

Exit Sub

End If

' 市松模様（チェッカーパターン）に選択

For rowIndex = 1 To rng.Rows.Count

For colIndex = 1 To rng.Columns.Count

If (rowIndex + colIndex) Mod 2 = 0 Then

Set cell = rng.Cells(rowIndex, colIndex)

If newSelection Is Nothing Then

Set newSelection = cell

Else

Set newSelection = Union(newSelection, cell)

End If

End If

Next colIndex

Next rowIndex

' 選択を適用

If Not newSelection Is Nothing Then

newSelection.Select

End If

MsgBox "市松模様（チェッカーパターン）で選択しました！", _

vbInformation, "完了"

End Sub

エリアを選択し・・・

実行すると市松模様的に選択した状態になるので・・・

カラーパレットで任意の色を設定。

シンプルな動きの方が応用が利きますね。

Excel VBA 47 Excelで選択したエリアを一列おきに選択

Excelで選択したエリアを一行おきに選択し、色を設定します。

デフォルト環境で設定するのが面倒くさいので作成した一行版の一列版です。

Sub SelectAlternateColumnsWithinSelection()

Dim rng As Range

Dim colRange As Range

Dim newSelection As Range

Dim colIndex As Integer

' 選択範囲を取得

On Error Resume Next

Set rng = Selection

On Error GoTo 0

' 範囲が選択されていない場合、エラーを表示

If rng Is Nothing Then

MsgBox "セル範囲を選択してください。", _

vbExclamation, "エラー"

Exit Sub

End If

' 選択範囲の1列おきの列を取得

For colIndex = 1 To rng.Columns.Count Step 2

Set colRange = rng.Columns(colIndex)

If newSelection Is Nothing Then

Set newSelection = colRange

Else

Set newSelection = Union(newSelection, colRange)

End If

Next colIndex

' 選択を適用

If Not newSelection Is Nothing Then

newSelection.Select

End If

MsgBox "選択範囲内の1列おきの列を選択しました！", _

vbInformation, "完了"

End Sub

エリアを選択し・・・

実行すると1列おきに選択した状態になるので・・・

カラーパレットで任意の色を設定。

シンプルな動きの方が応用が利きますね。

Excel VBA 46 Excelで選択したエリアを一行おきに選択

Excelで選択したエリアを一行おきに選択し、色を設定します。

デフォルト環境で設定するのが面倒くさいので作成して見ました。

Sub SelectAlternateRowsWithinSelection()

Dim rng As Range

Dim rowRange As Range

Dim newSelection As Range

Dim rowIndex As Integer

' 選択範囲を取得

On Error Resume Next

Set rng = Selection

On Error GoTo 0

' 範囲が選択されていない場合、エラーを表示

If rng Is Nothing Then

MsgBox "セル範囲を選択してください。", _

vbExclamation, "エラー"

Exit Sub

End If

' 選択範囲の1行おきの行を取得

For rowIndex = 1 To rng.Rows.Count Step 2

Set rowRange = rng.Rows(rowIndex)

If newSelection Is Nothing Then

Set newSelection = rowRange

Else

Set newSelection = _

Union(newSelection, rowRange)

End If

Next rowIndex

' 選択を適用

If Not newSelection Is Nothing Then

newSelection.Select

End If

MsgBox "選択範囲内の1行おきの行を選択しました！", _

vbInformation, "完了"

End Sub

エリアを選択し・・・

実行すると1行おきに選択した状態になるので・・・

カラーパレットで任意の色を設定。

シンプルな動きの方が応用が利きますね。

Excel VBA 45 Excelで選択したセルの和暦を西暦に変換

Excelで選択したセルの和暦を西暦に変換します。手動でメニューから変更するのが面倒なので作りました。

Sub ConvertToSeireki()

Dim cell As Range

Dim seireki As Date

' 選択範囲の各セルを処理

For Each cell In Selection

If IsDate(cell.Value) Then

' 西暦に変換

seireki = CDate(cell.Value)

cell.Value = Format(seireki, "yyyy年m月d日")

End If

Next cell

End Sub

"yyyy年m月d日"の部分を変更することで処理結果を調整出来ます。

和暦を選択して実行・・・

処理結果。

Excel VBA 44 Excelで選択したセルの西暦を和暦に変換

Excelで選択したセルの西暦を和暦に変換します。手動でメニューから変更するのが面倒なので作りました。

Sub ConvertToWareki()

Dim cell As Range

Dim wareki As String

' 選択範囲の各セルを処理

For Each cell In Selection

If IsDate(cell.Value) Then

' 和暦（元号）に変換

wareki = Format(cell.Value, "gggee年m月d日")

cell.Value = wareki

End If

Next cell

End Sub

"gggee年m月d日"の部分を変更することで処理結果を調整出来ます。

西暦を選択して実行・・・

処理結果。

Excel VBA 43 Excelで選択した行の高さを一括変更

書式設定で処理出来ますが、Excelで選択した行の高さを一括変更します。

Sub SetSelectedRowsHeight()

Dim rng As Range

Dim row As Range

Dim height As Double

' ユーザーに行の高さを入力させる

height = InputBox("設定する行の高さを入力してください",

        "行高さ設定", 20)

' ユーザーがキャンセルした場合は処理を中断

If height = 0 Then Exit Sub

' 選択範囲を取得

Set rng = Selection

' 選択範囲の各行に適用

For Each row In rng.Rows

row.RowHeight = height

Next row

MsgBox "選択範囲の行の高さを " & height &

        " に設定しました。", vbInformation, "設定完了"

End Sub

変更したい行を選択し・・・

マクロを起動すると変更したい行の入力パレットが表示されます。値20はデフォルトの幅です。

任意変更して［OK］すれば・・・

指定した行に変更されます。

Excel VBA 42 Excelで選択した列の幅を一括変更

書式設定で処理出来ますが、Excelで選択した列の幅を一括変更します。

Sub SetSelectedColumnsWidth()

Dim rng As Range

Dim col As Range

Dim width As Double

' ユーザーに列幅を入力させる

width = InputBox("設定する列の幅を入力してください",

        "列幅設定", 10)

' ユーザーがキャンセルした場合は処理を中断

If width = 0 Then Exit Sub

' 選択範囲を取得

Set rng = Selection

' 選択範囲の各列に適用

For Each col In rng.Columns

col.ColumnWidth = width

Next col

MsgBox "選択範囲の列幅を " & width & " に設定しました。",

        vbInformation, "設定完了"

End Sub

変更したい列を選択し・・・

マクロを起動すると変更したい幅の入力パレットが表示されます。値10はデフォルトの幅です。

任意変更して［OK］すれば・・・

指定した幅に変更されます。

Excel VBA 41 ExccelでA2とA2セルの色を指定段階のグラデに

ExccelでA2とA2セルの色から指定した段階のグラデ—ションを作成します。

Sub GradientFillWithSteps()

Dim color1 As Long, color2 As Long

Dim r1 As Integer, g1 As Integer, b1 As Integer

Dim r2 As Integer, g2 As Integer, b2 As Integer

Dim stepCount As Integer

Dim i As Integer

Dim newR As Integer, newG As Integer, newB As Integer

Dim stepR As Double, stepG As Double, stepB As Double

' 塗りつぶし色を取得

color1 = Range("A1").Interior.Color

color2 = Range("A2").Interior.Color

' RGB値を分解

r1 = color1 Mod 256

g1 = (color1 ¥ 256) Mod 256

b1 = (color1 ¥ 256 ¥ 256) Mod 256

r2 = color2 Mod 256

g2 = (color2 ¥ 256) Mod 256

b2 = (color2 ¥ 256 ¥ 256) Mod 256

' 段階数を入力

stepCount = Application.InputBox("_

        段階数を入力してください（整数）:", Type:=1)

' 入力が無効な場合は終了

If stepCount <= 0 Then

MsgBox "有効な段階数を入力してください。", vbExclamation

Exit Sub

End If

' 色の変化量を計算

stepR = (r2 - r1) / stepCount

stepG = (g2 - g1) / stepCount

stepB = (b2 - b1) / stepCount

' B列にグラデーションを適用

Application.ScreenUpdating = False

For i = 1 To stepCount

newR = r1 + stepR * i

newG = g1 + stepG * i

newB = b1 + stepB * i

Range("B" & i).Interior.Color = RGB(newR, newG, newB)

Next i

Application.ScreenUpdating = True

MsgBox "グラデーションの塗りつぶしが完了しました！", _

        vbInformation

End Sub

A1とA2セルに基準となる塗りを行い、VBAを実行すると・・・

段階数を入力するパレットが表示されるので任意入力すれば・・・

指定段階段階の基準の色の間となる段階の塗りをB列に表示します。