kendrick-kamakuraのブログ

20260701 細かな修正

Wed, 01 Jul 2026 00:13:57 +0900

Dim c As Range

Dim NextMin As Double

NextMin = 1E+308

For Each c In wsList.Range("A1", wsList.Cells(wsList.Rows.Count, "A").End(xlUp))

If IsNumeric(c.Value) Then

If c.Value > MinNum And c.Value < NextMin Then

NextMin = c.Value

End If

If NextMin <> 1E+308 Then

MinNum = NextMin

Else

MsgBox "該当する値はありません。"

End If

'MinNumの数値が入っている行を特定する

RowNum = Application.WorksheetFunction.Match(MinNum, wsList.Range("A:A"), 0)

If wsList.Cells(RowNum, "C").Value <> "" Then

'C列に文字があるなら

Main_Text = Main_Text & wsList.Cells(RowNum, "B").Value & vbLf & wsList.Cells(RowNum, "C").Value & vbLf & vbLf

Else

'C列に文字がないなら

Main_Text = Main_Text & wsList.Cells(RowNum, "B").Value & vbLf & vbLf

End If

If MinNum = MaxNum Then Exit Do

Loop

'セルコピー

If Target.Address = "$C$6" Then

If Range("F6").Value = "○" Then

Range("A1:B1").Copy

Else

Range("A1").Copy

End If

Cancel = True

細かな修正をしました

Tue, 30 Jun 2026 00:31:08 +0900

Dim c As Range

Dim NextMin As Double

NextMin = 1E+308

For Each c In wsList.Range("A1", wsList.Cells(wsList.Rows.Count, "A").End(xlUp))

If IsNumeric(c.Value) Then

If c.Value > MinNum And c.Value < NextMin Then

NextMin = c.Value

End If

If NextMin <> 1E+308 Then

MinNum = NextMin

Else

MsgBox "該当する値はありません。"

End If

VBAツール　アップデート内容　2026年6月28日

Sun, 28 Jun 2026 19:27:37 +0900

VBA設定

・F2.3 追完の頭文あげる

・1からナンバリング

・コピーするときにC1をセレクトするようにする

A列をダブルクリックしたときにダブルクリックしたセルに数字を

変更１（１度目と２度目での追完のメールの文章を変化）

VBA以外の変更点

・入力シートのB5に書かれていた内容をD2.D3に場合分けして移動

・元々D2〜E3にあった内容はE2〜F3へ移動

VBA変更点

ー追完メール本文ー

'メール前半部を作成する

Dim First_Text As String

First_Text = wsIn.Range("D" & R).Value & vbLf & _

wsIn.Range("E" & R).Value & wsIn.Range("B6").Value & StrConv(Format(wsIn.Range("C6").Value, "000000"), vbWide) & wsIn.Range("D6").Value & vbLf & _

wsIn.Range("B7").Value & StrConv(Format(wsIn.Range("C" & R).Value, "yyyy年m月d日"), vbWide) & wsIn.Range("B9").Value & vbLf & vbLf

'③メール末尾を作成

Dim End_Text As String

End_Text = wsIn.Range("F" & R).Value

追完資料に番号を付け、任意の順番で並べられるようにする

・「一覧」シート

Option Explicit

'A列をダブルクリックした時に、そのセルに文字が入っていない場合は番号を１つ進め、数字を入力する。文字が入っている場合は、その文字を消す

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Target.Column = 1 And Target.Cells.Count = 1 Then

If Trim(Target.Value & "") = "" Then

'セルが空白なら番号を１つ進め、数字を入力

Target.Value = WorksheetFunction.Max(Columns("A")) + 1

Else

' 値が入っているなら消す

Target.ClearContents

End If

' 編集モードに入らない

Cancel = True

End Sub

'A列に文字が入ってる場合はその行をオレンジにする、A列に文字が入ってなかったら塗りつぶしをやめる

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Column = 1 And Target.Cells.Count = 1 Then

If Trim(Target.Value) <> "" Then

' A列に値がある場合

Rows(Target.Row).Interior.Color = RGB(255, 192, 0)

Else

' A列が空白の場合

Rows(Target.Row).Interior.Pattern = xlNone

End If

End Sub

・「追完メール本文」シート

Option Explicit

'②で使う変数を定義

Dim wsList As Worksheet

Dim MinNum As Double

Dim Main_Text As String

'②メール本文を作成

Set wsList = ThisWorkbook.Worksheets("一覧")

MinNum = 0

Main_Text = ""

'「一覧」シートのA列に入力されている値の最大値を探す

Dim MaxNum As Double

MaxNum = Application.WorksheetFunction.Max(wsList.Range("A:A"))

'現在のMinNum以上の最小値を探す変数、MinNumの値がMaxNumと同じになるまで､MinNumの右隣にあるコンテンツをメール本文に加え続ける

Dim RowNum As Long

'現在のMinNum以上の最小値を探す

MinNum = Application.WorksheetFunction.MinIfs( _

wsList.Range("A:A"), _

wsList.Range("A:A"), ">" & MinNum)

RowNum = Application.WorksheetFunction.Match(MinNum, wsList.Range("A:A"), 0)

Main_Text = Main_Text & wsList.Cells(RowNum, "B").Value & vbLf & wsList.Cells(RowNum, "C").Value & vbLf

If MinNum = MaxNum Then Exit Do

Loop

以下コード全文

・「入力」シート

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

' A2.A3セルのみ対象

If Target.Address = "$A$2" Or Target.Address = "$A$3" Then

If Trim(Target.Value & "") = "" Then

'A2.A3のセルの選択を解除し、行の塗りつぶしを解除する

Range("A2:A3").ClearContents

Rows("2:3").Interior.Pattern = xlNone

' 空白なら0を入力

Target.Value = 0

Else

' 値が入っているなら消し、A2.A3のセルをピンクに塗りつぶす

Target.ClearContents

Range("A2:A3").Interior.Color = RGB(255, 199, 206)

End If

' 編集モードに入らない

Cancel = True

End If

End Sub

'A列に文字が入ってる場合はその行をオレンジにする、A列に文字が入ってなかったら塗りつぶしをやめる

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Column = 1 And Target.Cells.Count = 1 Then

If Trim(Target.Value) <> "" Then

' A列に値がある場合

Rows(Target.Row).Interior.Color = RGB(255, 192, 0)

Else

' A列が空白の場合

Rows(Target.Row).Interior.Pattern = xlNone

End If

End Sub

・「一覧」シート

Option Explicit

'A列をダブルクリックした時に、そのセルに文字が入っていない場合は番号を１つ進め、数字を入力する。文字が入っている場合は、その文字を消す

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Target.Column = 1 And Target.Cells.Count = 1 Then

If Trim(Target.Value & "") = "" Then

'セルが空白なら番号を１つ進め、数字を入力

Target.Value = WorksheetFunction.Max(Columns("A")) + 1

Else

' 値が入っているなら消す

Target.ClearContents

End If

' 編集モードに入らない

Cancel = True

End If

End Sub

'A列に文字が入ってる場合はその行をオレンジにする、A列に文字が入ってなかったら塗りつぶしをやめる

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Column = 1 And Target.Cells.Count = 1 Then

If Trim(Target.Value) <> "" Then

' A列に値がある場合

Rows(Target.Row).Interior.Color = RGB(255, 192, 0)

Else

' A列が空白の場合

Rows(Target.Row).Interior.Pattern = xlNone

End If

End Sub

・「追完メール本文」シート

Option Explicit

'②で使う変数を定義

Dim wsList As Worksheet

Dim MinNum As Double

Dim Main_Text As String

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

'■メール文作成

If Target.Address = "$C$1" Or Target.Address = "$C$3" Then

'①メール前半部を作成

'「入力」セルのA列の一番上の文字が入力されているセルの行を変数rとして定義

Dim wsIn As Worksheet

Set wsIn = ThisWorkbook.Worksheets("入力")

Dim R As Long

For R = 1 To wsIn.Rows.Count

If wsIn.Cells(R, 1).Value <> "" Then

Exit For

End If

Next R

'メール前半部を作成する

Dim First_Text As String

First_Text = wsIn.Range("D" & R).Value & vbLf & _

wsIn.Range("E" & R).Value & wsIn.Range("B6").Value & StrConv(Format(wsIn.Range("C6").Value, "000000"), vbWide) & wsIn.Range("D6").Value & vbLf & _

wsIn.Range("B7").Value & StrConv(Format(wsIn.Range("C" & R).Value, "yyyy年m月d日"), vbWide) & wsIn.Range("B9").Value & vbLf & vbLf

'②メール本文を作成

Set wsList = ThisWorkbook.Worksheets("一覧")

MinNum = 0

Main_Text = ""

'「一覧」シートのA列に入力されている値の最大値を探す

Dim MaxNum As Double

MaxNum = Application.WorksheetFunction.Max(wsList.Range("A:A"))

'現在のMinNum以上の最小値を探す変数、MinNumの値がMaxNumと同じになるまで､MinNumの右隣にあるコンテンツをメール本文に加え続ける

Dim RowNum As Long

'現在のMinNum以上の最小値を探す

MinNum = Application.WorksheetFunction.MinIfs( _

wsList.Range("A:A"), _

wsList.Range("A:A"), ">" & MinNum)

RowNum = Application.WorksheetFunction.Match(MinNum, wsList.Range("A:A"), 0)

Main_Text = Main_Text & wsList.Cells(RowNum, "B").Value & vbLf & wsList.Cells(RowNum, "C").Value & vbLf

If MinNum = MaxNum Then Exit Do

Loop

'③メール末尾を作成

Dim End_Text As String

End_Text = wsIn.Range("F" & R).Value

'C1セルをダブルクリックした時に、オンライン用プレビューを作成

If Target.Address = "$C$1" Then

Range("A1").Value = First_Text & Main_Text & End_Text

Range("B1").Value = wsIn.Range("C" & R).Value

Cancel = True

End If

'C3セルをダブルクリックした時に、窓追完用プレビューを作成

If Target.Address = "$C$3" Then

Range("A1").Value = Main_Text

Cancel = True

End If

'■印刷＆セルコピー

'セルコピー

If Target.Address = "$C$6" Then

Range("A1:B1").Copy

Cancel = True

End If

'印刷

If Target.Address = "$C$8" Then

'Range("A1").PrintPreview

'Range("A1").PrintOut

Cancel = True

End If

'■入力した内容を消去する

'日付以外の入力内容を消去する

If Target.Address = "$C$11" Then

Range("A1:A20").ClearContents

Range("B1").ClearContents

ThisWorkbook.Worksheets("一覧").Columns("A").ClearContents

ThisWorkbook.Worksheets("一覧").Columns("C").ClearContents

ThisWorkbook.Worksheets("一覧").Cells.Interior.Pattern = xlNone

ThisWorkbook.Worksheets("入力").Range("C6").ClearContents

ThisWorkbook.Worksheets("入力").Activate

ThisWorkbook.Worksheets("入力").Range("C6").Select

Cancel = True

End If

'全ての入力内容を消去する

If Target.Address = "$C$13" Then

Range("A1:A20").ClearContents

Range("B1").ClearContents

ThisWorkbook.Worksheets("一覧").Columns("A").ClearContents

ThisWorkbook.Worksheets("一覧").Columns("C").ClearContents

ThisWorkbook.Worksheets("一覧").Cells.Interior.Pattern = xlNone

ThisWorkbook.Worksheets("入力").Range("C6").ClearContents

ThisWorkbook.Worksheets("入力").Columns("A").ClearContents

ThisWorkbook.Worksheets("入力").Rows("2:3").Interior.Pattern = xlNone

ThisWorkbook.Worksheets("入力").Range("A2:A3").Interior.Color = RGB(255, 199, 206)

ThisWorkbook.Worksheets("入力").Range("C2").Value = "=WORKDAY(TODAY(),IF(MOD(NOW(),1)<=TIME(12,30,0),10,11))"

ThisWorkbook.Worksheets("入力").Range("C3").Value = "=WORKDAY(TODAY(),IF(MOD(NOW(),1)<=TIME(12,30,0),5,6))"

ThisWorkbook.Worksheets("入力").Activate

ThisWorkbook.Worksheets("入力").Range("C6").Select

Cancel = True

End If

End Sub

メールの作成を自動化しよう　その２（Excel・VBA）

Wed, 17 Jun 2026 00:32:35 +0900

前回作成したツールに変更点を追加しました

変更点

その１

'「一覧」シートのA行に文字が入っている列のコンテンツについて、変数「Main_Text」に加える。

For i = 1 To LastRow

If wsList.Cells(i, "A").Value <> "" Then

If wsList.Cells(i, "C").Value <> "" Then

Main_Text = Main_Text & wsList.Cells(i, "B").Value & vbLf & wsList.Cells(i, "C").Value & vbLf & vbLf

Else

Main_Text = Main_Text & wsList.Cells(i, "B").Value & vbLf & vbLf

End If

Next i

その２（どちらにも（ThisWorkbook.Worksheets("一覧").Columns("C").ClearContents）を追加）

'■入力した内容を消去する

'日付以外の入力内容を消去する

If Target.Address = "$C$11" Then

Range("A1:A20").ClearContents

ThisWorkbook.Worksheets("一覧").Columns("A").ClearContents

ThisWorkbook.Worksheets("一覧").Columns("C").ClearContents

ThisWorkbook.Worksheets("一覧").Cells.Interior.Pattern = xlNone

ThisWorkbook.Worksheets("入力").Range("C6").ClearContents

ThisWorkbook.Worksheets("入力").Activate

ThisWorkbook.Worksheets("入力").Range("C6").Select

Cancel = True

End If

'全ての入力内容を消去する

If Target.Address = "$C$13" Then

Range("A1:A20").ClearContents

ThisWorkbook.Worksheets("一覧").Columns("A").ClearContents

ThisWorkbook.Worksheets("一覧").Columns("C").ClearContents

ThisWorkbook.Worksheets("一覧").Cells.Interior.Pattern = xlNone

ThisWorkbook.Worksheets("入力").Range("C6").ClearContents

ThisWorkbook.Worksheets("入力").Columns("A").ClearContents

ThisWorkbook.Worksheets("入力").Rows("2:3").Interior.Pattern = xlNone

ThisWorkbook.Worksheets("入力").Range("A2:A3").Interior.Color = RGB(255, 199, 206)

ThisWorkbook.Worksheets("入力").Range("C2").Value = "=WORKDAY(TODAY(),IF(MOD(NOW(),1)<=TIME(12,30,0),10,11))"

ThisWorkbook.Worksheets("入力").Range("C3").Value = "=WORKDAY(TODAY(),IF(MOD(NOW(),1)<=TIME(12,30,0),5,6))"

ThisWorkbook.Worksheets("入力").Activate

ThisWorkbook.Worksheets("入力").Range("C6").Select

Cancel = True

End If

その３

変更点

StrConv(Format(wsIn.Range("C6").Value, "000000"), vbWide)

StrConv(Format(wsIn.Range("C" & R).Value, "yyyy年m月d日"), vbWide)

全文

'メール前半部を作成する

Dim First_Text As String

First_Text = wsIn.Range("B5").Value & vbLf & _

wsIn.Range("D" & R).Value & wsIn.Range("B6").Value & StrConv(Format(wsIn.Range("C6").Value, "000000"), vbWide) & wsIn.Range("D6").Value & vbLf & _

wsIn.Range("B7").Value & StrConv(Format(wsIn.Range("C" & R).Value, "yyyy年m月d日"), vbWide) & wsIn.Range("B9").Value & vbLf & vbLf

その４

'■印刷＆セルコピー

'セルコピー

If Target.Address = "$C$6" Then

Range("A1").Copy

Cancel = True

End If

'印刷

If Target.Address = "$C$8" Then

'Range("A1").PrintPreview

'Range("A1").PrintOut

Cancel = True

End If

メールの作成を自動化しよう（Excel・VBA）

Mon, 15 Jun 2026 00:24:54 +0900

メールを自動で作成できるようにしましょう。

（以下をコピー）

Sheet1

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

' A2.A3セルのみ対象

If Target.Address = "$A$2" Or Target.Address = "$A$3" Then

If Trim(Target.Value & "") = "" Then

'A2.A3のセルの選択を解除し、行の塗りつぶしを解除する

Range("A2:A3").ClearContents

Rows("2:3").Interior.Pattern = xlNone

' 空白なら0を入力

Target.Value = 0

Else

' 値が入っているなら消し、A2.A3のセルをピンクに塗りつぶす

Target.ClearContents

Range("A2:A3").Interior.Color = RGB(255, 199, 206)

End If

' 編集モードに入らない

Cancel = True

End If

End Sub

'A列に文字が入ってる場合はその行をオレンジにする、A列に文字が入ってなかったら塗りつぶしをやめる

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Column = 1 And Target.Cells.Count = 1 Then

If Trim(Target.Value) <> "" Then

' A列に値がある場合

Rows(Target.Row).Interior.Color = RGB(255, 192, 0)

Else

' A列が空白の場合

Rows(Target.Row).Interior.Pattern = xlNone

End If

End Sub

Sheet2

Option Explicit

'A列をダブルクリックした時に、そのセルに文字が入っていない場合は0を表示させる。文字が入っている場合は、その文字を消す

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

' A列の1セルのみ対象

If Target.Column = 1 And Target.Cells.Count = 1 Then

If Trim(Target.Value & "") = "" Then

' 空白なら0を入力

Target.Value = 0

Else

' 値が入っているなら消す

Target.ClearContents

End If

' 編集モードに入らない

Cancel = True

End If

End Sub

'A列に文字が入ってる場合はその行をオレンジにする、A列に文字が入ってなかったら塗りつぶしをやめる

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Column = 1 And Target.Cells.Count = 1 Then

If Trim(Target.Value) <> "" Then

' A列に値がある場合

Rows(Target.Row).Interior.Color = RGB(255, 192, 0)

Else

' A列が空白の場合

Rows(Target.Row).Interior.Pattern = xlNone

End If

End Sub

Sheet3

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

'■メール文作成

If Target.Address = "$C$1" Or Target.Address = "$C$3" Then

'①メール前半部を作成

'「入力」セルのA列の一番上の文字が入力されているセルの行を変数rとして定義

Dim wsIn As Worksheet

Set wsIn = ThisWorkbook.Worksheets("入力")

Dim R As Long

For R = 1 To wsIn.Rows.Count

If wsIn.Cells(R, 1).Value <> "" Then

Exit For

End If

Next R

'メール前半部を作成する

Dim First_Text As String

First_Text = wsIn.Range("B5").Value & vbLf & _

wsIn.Range("D" & R).Value & wsIn.Range("B6").Value & Format(wsIn.Range("C6").Value, "000000") & wsIn.Range("D6").Value & vbLf & _

wsIn.Range("B7").Value & wsIn.Range("C" & R).Value & wsIn.Range("B9").Value & vbLf & vbLf

'②メール本文を作成

'「一覧」シートのA列に文字が入力されている最終セルの行数を取得

Dim wsList As Worksheet

Dim LastRow As Long

Dim i As Long

Dim Main_Text As String

Set wsList = ThisWorkbook.Worksheets("一覧")

Main_Text = ""

'A列の最終入力行

LastRow = wsList.Cells(wsList.Rows.Count, "A").End(xlUp).Row

'「一覧」シートのA行に文字が入っている列のコンテンツについて、変数「Main_Text」に加える。

For i = 1 To LastRow

If wsList.Cells(i, "A").Value <> "" Then

Main_Text = Main_Text & "・" & wsList.Cells(i, "B").Value & vbLf & vbLf

End If

Next i

'③メール末尾を作成

Dim End_Text As String

End_Text = wsIn.Range("E" & R).Value

'C1セルをダブルクリックした時に、オンライン用プレビューを作成

If Target.Address = "$C$1" Then

Range("A1").Value = First_Text & Main_Text & End_Text

Cancel = True

End If

'C3セルをダブルクリックした時に、窓追完用プレビューを作成

If Target.Address = "$C$3" Then

Range("A1").Value = Main_Text

Cancel = True

End If

'■印刷＆セルコピー

If Target.Address = "$C$6" Then

'Range("A1").PrintPreview

'Range("A1").PrintOut

Range("A1").Copy

Cancel = True

End If

'■入力した内容を消去する

'日付以外の入力内容を消去する

If Target.Address = "$C$11" Then

Range("A1:A20").ClearContents

ThisWorkbook.Worksheets("一覧").Columns("A").ClearContents

ThisWorkbook.Worksheets("一覧").Cells.Interior.Pattern = xlNone

ThisWorkbook.Worksheets("入力").Range("C6").ClearContents

ThisWorkbook.Worksheets("入力").Activate

ThisWorkbook.Worksheets("入力").Range("C6").Select

Cancel = True

End If

'全ての入力内容を消去する

If Target.Address = "$C$13" Then

Range("A1:A20").ClearContents

ThisWorkbook.Worksheets("一覧").Columns("A").ClearContents

ThisWorkbook.Worksheets("一覧").Cells.Interior.Pattern = xlNone

ThisWorkbook.Worksheets("入力").Range("C6").ClearContents

ThisWorkbook.Worksheets("入力").Columns("A").ClearContents

ThisWorkbook.Worksheets("入力").Rows("2:3").Interior.Pattern = xlNone

ThisWorkbook.Worksheets("入力").Range("A2:A3").Interior.Color = RGB(255, 199, 206)

ThisWorkbook.Worksheets("入力").Range("C2").Value = "=WORKDAY(TODAY(),IF(MOD(NOW(),1)<=TIME(12,30,0),10,11))"

ThisWorkbook.Worksheets("入力").Range("C3").Value = "=WORKDAY(TODAY(),IF(MOD(NOW(),1)<=TIME(12,30,0),5,6))"

ThisWorkbook.Worksheets("入力").Activate

ThisWorkbook.Worksheets("入力").Range("C6").Select

Cancel = True

End If

End Sub

Excel・VBAで役に立つ情報を発信していきます。

Tue, 09 Jun 2026 20:45:19 +0900

Excelでダブルクリックしたセルを選択する方法

↓ここからコピー&ペースト

'A列をダブルクリックした時に、そのセルに文字が入っていない場合は0を表示させる。文字が入っている場合は、その文字を消す

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

' A列の1セルのみ対象

If Target.Column = 1 And Target.Cells.Count = 1 Then

If Trim(Target.Value & "") = "" Then

' 空白なら0を入力

Target.Value = 0

Else

' 値が入っているなら消す

Target.ClearContents

End If

' 編集モードに入らない

Cancel = True

End If

End Sub

kendrick-kamakuraのブログ

20260701 細かな修正

細かな修正をしました

VBAツール アップデート内容 2026年6月28日

メールの作成を自動化しよう その２（Excel・VBA）

メールの作成を自動化しよう（Excel・VBA）

Excel・VBAで役に立つ情報を発信していきます。

VBAツール　アップデート内容　2026年6月28日

メールの作成を自動化しよう　その２（Excel・VBA）