Excel VBA 質問スレッド №2175 (未解決)
vbaおかしい
投稿者 : メ 投稿日時 : 2026/03/09(Mon) 07:19:51 OS : 未指定 EXCEL : 未指定
また、これを実行しても動きません。
Option Explicit
'========================================
' メイン処理
' 外部データの色を取得して
' 入力シートと出力シートへ書き込む
'========================================
Sub データ更新()
'画面更新を止めて高速化
Application.ScreenUpdating = False
'自動計算を停止（高速化）
Application.Calculation = xlCalculationManual
'ワークシート変数
Dim wsIn As Worksheet '入力シート
Dim wsOut As Worksheet '出力シート
Dim wsExt As Worksheet '外部データシート
Dim wbExt As Workbook '外部データブック
'年月
Dim Y As Long
Dim M As Long
'ループ用
Dim i As Long
'月の日数
Dim lastDay As Long
'シート設定
Set wsIn = Worksheets("入力")
Set wsOut = Worksheets("出力")
'入力シートから年と月を取得
Y = wsIn.Range("A1").Value
M = wsIn.Range("B1").Value
'その月の最終日を取得
lastDay = Day(DateSerial(Y, M + 1, 0))
'========================================
' 外部ブックを探す
'========================================
Dim wb As Workbook
'現在開いているブックを順番に確認
For Each wb In Workbooks
'このブック自身は除外
If wb.Name <> ThisWorkbook.Name Then
'年と同じ名前のシートがあるか確認
On Error Resume Next
Set wsExt = wb.Worksheets(CStr(Y))
On Error GoTo 0
'見つかったら外部ブック確定
If Not wsExt Is Nothing Then
Set wbExt = wb
Exit For
End If
End If
Next
'外部データが見つからない場合
If wsExt Is Nothing Then
MsgBox "外部データが見つかりません"
GoTo EndProc
End If
'========================================
' シート初期化
'========================================
'2～40行の内容をクリア
wsIn.Range("A2:B40").ClearContents
wsOut.Range("A2:B40").ClearContents
'========================================
' 日付と色を取得
'========================================
For i = 1 To lastDay
'日付を入力
wsIn.Cells(i + 1, 1).Value = DateSerial(Y, M, i)
wsOut.Cells(i + 1, 1).Value = DateSerial(Y, M, i)
'外部データのセル色を取得
wsIn.Cells(i + 1, 2).Value = wsExt.Cells(i + 1, 1).Interior.Color
wsOut.Cells(i + 1, 2).Value = wsExt.Cells(i + 1, 1).Interior.Color
Next i
EndProc:
'画面更新を戻す
Application.ScreenUpdating = True
'自動計算を戻す
Application.Calculation = xlCalculationAutomatic
End Sub
'========================================
' 先月へ移動ボタン
'========================================
Sub 先月()
Dim Y As Long
Dim M As Long
'入力シートから年と月取得
With Worksheets("入力")
Y = .Range("A1").Value
M = .Range("B1").Value
'月を1つ減らす
M = M - 1
'1月の場合は前年の12月へ
If M = 0 Then
M = 12
Y = Y - 1
End If
'シートへ戻す
.Range("A1") = Y
.Range("B1") = M
End With
'データ更新
Call データ更新
End Sub
'========================================
' 翌月へ移動ボタン
'========================================
Sub 翌月()
Dim Y As Long
Dim M As Long
'入力シートから年と月取得
With Worksheets("入力")
Y = .Range("A1").Value
M = .Range("B1").Value
'月を1つ増やす
M = M + 1
'12月の場合は翌年の1月へ
If M = 13 Then
M = 1
Y = Y + 1
End If
'シートへ戻す
.Range("A1") = Y
.Range("B1") = M
End With
'データ更新
Call データ更新
End Sub
これを使用して、色を取得して、日にちことに色を変えていきたいのですができますか？また、これを実行しても動きません。
スポンサーリンク
[返信 1] Re : vbaおかしい
投稿者 : 4x4my 投稿日時 : 2026/03/09(Mon) 08:19:53
vba「おかしい」って、何がどうおかしいのかは第三者には分かりません。
そもそもそのマクロでどういう処理をしたいのか、まずそれを説明しないと、長ったらしい「おかしい」コードなど読む気になれません。
それから違っていたらごめんなさいですが、投稿のたびに名前を変えるのやめましょうよ。
vba「おかしい」って、何がどうおかしいのかは第三者には分かりません。
そもそもそのマクロでどういう処理をしたいのか、まずそれを説明しないと、長ったらしい「おかしい」コードなど読む気になれません。
それから違っていたらごめんなさいですが、投稿のたびに名前を変えるのやめましょうよ。
[返信 2] Re : vbaおかしい
投稿者 : MDQ 投稿日時 : 2026/03/10(Tue) 16:51:38
探すの変数をCと置いて入力と出力を文字で固定して先月と翌月をユーザーフォームのボタンとして行うと
どのようになるのか確認しますよね
探すの変数をCと置いて入力と出力を文字で固定して先月と翌月をユーザーフォームのボタンとして行うと
どのようになるのか確認しますよね
[返信 3] Re : vbaおかしい
投稿者 : メ 投稿日時 : 2026/03/11(Wed) 11:15:26
■ MDQさん（2026-03-10 16:51:38）の記事
＞ 探すの変数をCと置いて
その置き方はできません。
置くとしたら
Q3のデータを探して行うことになります
また、２列の分けて行っていますか。
最初についてはJ３：P3のところに"そのままの文字("
Q3 :T3のところに"令和７年"
w3のところに"B1"
X3:Y3のところに"月)"と表示していますか
日付と曜日については２列２行の形となっていますか
メンバーについては10列２行の形となっていますか
班については色だけで識別になっていますか
A１に西暦 B１に使用する月
これがすべてできているかエクセルを確認して
色はエクセルの書式設定で
班ごとに設定日付と曜日とメンバーのすべてに色を塗りつぶし
メンバーの名前を入れると色が白に変わる
土日祝日は曜日の文字が自動で赤に変わる
となっているので、追加で別のエクセルで班がわかれば書式設定により行われる
ユーザーフォームについては先月と翌月のボタン付きとする
A1とB1はユーザーフォームと連動している
集計シートも作成する
１班から３班のみ
名前が入れは班と名前を認識してデータにある一人ひとりが計算される。
月に関しては、火曜日と土曜日と全曜日
年に関しては、年火曜日と年土曜日と年全曜日とする
全曜日＝月曜日から日曜日
年全曜日＝１月から12月の月曜日から日曜日
年火曜日＝１月から12月の火曜日
年土曜日＝１月から12月の土曜日
最初については１行目で 年 ４月から３月
２行目で 班 氏名 ループ（火曜日 土曜日 全曜日）
とする
外部シートは例みたいに１月から12月まである
入力シート）
文字(令和７年B1月)
日付 曜日 メンバー 日付 曜日 メンバー
ユーザーフォーム）
A1 年 B1 月 先月ボタン 翌月ボタン
集計シート）
１年 ４月 ５月 6月…12月 １月 ２月 ３月
班 氏名 火曜日 土曜日 全曜日・・・火曜日 土曜日 全曜日
集計シート）例
１年 ４月 …・
班 氏名 火曜日 土曜日 全曜日 火曜日 土曜日 全曜日
１ 田中 １ ０ １ １ ０ １
１ 山本 ０ ０ １ ０ ０ １
部外シート）例
日１２…30
曜火水…水
４色色…色
月
日１２…31
曜木金…土
５色色…色
月
■ MDQさん（2026-03-10 16:51:38）の記事
＞ 探すの変数をCと置いて
その置き方はできません。
置くとしたら
Q3のデータを探して行うことになります
また、２列の分けて行っていますか。
最初についてはJ３：P3のところに"そのままの文字("
Q3 :T3のところに"令和７年"
w3のところに"B1"
X3:Y3のところに"月)"と表示していますか
日付と曜日については２列２行の形となっていますか
メンバーについては10列２行の形となっていますか
班については色だけで識別になっていますか
A１に西暦 B１に使用する月
これがすべてできているかエクセルを確認して
色はエクセルの書式設定で
班ごとに設定日付と曜日とメンバーのすべてに色を塗りつぶし
メンバーの名前を入れると色が白に変わる
土日祝日は曜日の文字が自動で赤に変わる
となっているので、追加で別のエクセルで班がわかれば書式設定により行われる
ユーザーフォームについては先月と翌月のボタン付きとする
A1とB1はユーザーフォームと連動している
集計シートも作成する
１班から３班のみ
名前が入れは班と名前を認識してデータにある一人ひとりが計算される。
月に関しては、火曜日と土曜日と全曜日
年に関しては、年火曜日と年土曜日と年全曜日とする
全曜日＝月曜日から日曜日
年全曜日＝１月から12月の月曜日から日曜日
年火曜日＝１月から12月の火曜日
年土曜日＝１月から12月の土曜日
最初については１行目で 年 ４月から３月
２行目で 班 氏名 ループ（火曜日 土曜日 全曜日）
とする
外部シートは例みたいに１月から12月まである
入力シート）
文字(令和７年B1月)
日付 曜日 メンバー 日付 曜日 メンバー
ユーザーフォーム）
A1 年 B1 月 先月ボタン 翌月ボタン
集計シート）
１年 ４月 ５月 6月…12月 １月 ２月 ３月
班 氏名 火曜日 土曜日 全曜日・・・火曜日 土曜日 全曜日
集計シート）例
１年 ４月 …・
班 氏名 火曜日 土曜日 全曜日 火曜日 土曜日 全曜日
１ 田中 １ ０ １ １ ０ １
１ 山本 ０ ０ １ ０ ０ １
部外シート）例
日１２…30
曜火水…水
４色色…色
月
日１２…31
曜木金…土
５色色…色
月
[返信 4] Re : vbaおかしい
投稿者 : 天使 投稿日時 : 2026/03/13(Fri) 07:08:21
モジュール
モジュール
Option Explicit
'====================================================
' メイン処理
' ユーザーフォームの月変更ボタンから呼ばれる
'====================================================
Sub 月更新処理()
'処理速度を高速化
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'① 外部シートから班色取得
Call 外部班取得
'② 入力シートから集計更新
Call データ更新
'処理速度を元に戻す
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
'====================================================
' 外部シート → 入力シート
' 班色から班番号を表示
'====================================================
Sub 外部班取得()
Dim wbExt As Workbook
Dim wsExt As Worksheet
Dim wsIn As Worksheet
Dim path As String
'入力シート
Set wsIn = Worksheets("②入力")
'外部Excelの場所
path = ThisWorkbook.Path & "\外部データ.xlsx"
'外部Excelを開かずに取得
Set wbExt = GetObject(path)
'和暦シート名
Set wsExt = wbExt.Worksheets(wsIn.Range("C1").Value)
Dim r As Long
Dim colorVal As Long
Dim han As Integer
'1日〜31日を取得
For r = 5 To 35
'外部シートの班色を取得
colorVal = wsExt.Cells(r, 3).Interior.Color
'色 → 班番号変換
han = 班変換(colorVal)
'入力シートへ表示
wsIn.Cells(r, 3).Value = han
Next r
End Sub
'====================================================
' 班色 → 班番号変換
' （5班は存在しない）
'====================================================
Function 班変換(colorVal As Long) As Integer
Select Case colorVal
'1班（青）
Case RGB(68, 114, 196)
班変換 = 1
'2班（橙）
Case RGB(237, 125, 49)
班変換 = 2
'3班（紫）
Case RGB(112, 48, 160)
班変換 = 3
'4班（黄）
Case RGB(255, 255, 0)
班変換 = 4
'6班（緑）
Case RGB(112, 173, 71)
班変換 = 6
'該当なし
Case Else
班変換 = 0
End Select
End Function
'====================================================
' 集計処理
' 入力シートの名前を元に
' 集計シートの個人データを計算
'====================================================
Sub データ更新()
Dim wsIn As Worksheet
Dim wsSum As Worksheet
Set wsIn = Worksheets("②入力")
Set wsSum = Worksheets("③集計")
Dim r As Long
Dim name As String
Dim youbi As String
'入力データ確認
For r = 5 To 35
name = wsIn.Cells(r, 4).Value
youbi = wsIn.Cells(r, 2).Value
If name <> "" Then
Call 個人集計(name, youbi)
End If
Next r
End Sub
'====================================================
' 個人集計
'====================================================
Sub 個人集計(name As String, youbi As String)
Dim ws As Worksheet
Dim r As Long
Set ws = Worksheets("③集計")
For r = 2 To 50
If ws.Cells(r, 2).Value = name Then
'全曜日
ws.Cells(r, 5).Value = ws.Cells(r, 5).Value + 1
'火曜日
If youbi = "火" Then
ws.Cells(r, 3).Value = ws.Cells(r, 3).Value + 1
End If
'土曜日
If youbi = "土" Then
ws.Cells(r, 4).Value = ws.Cells(r, 4).Value + 1
End If
End If
Next r
End Sub
ユーザーフォームPrivate Sub btnPrev_Click()
With Worksheets("②入力")
.Range("B1").Value = .Range("B1").Value - 1
End With
Call 月更新処理
End Sub
とPrivate Sub btnNext_Click()
With Worksheets("②入力")
.Range("B1").Value = .Range("B1").Value + 1
End With
Call 月更新処理
End Sub
これで実行すると大丈夫です。[返信 5] Re : vbaおかしい
投稿者 : MDQ 投稿日時 : 2026/03/13(Fri) 17:31:28
ユーザーフォーム
これだと月だけ更新される
月と年を一緒に更新したい
また、ユーザーフォームのところにも月と年を表示したい
ユーザーフォーム
Private Sub btnPrev_Click()
With Worksheets("②入力")
.Range("B1").Value = .Range("B1").Value - 1
End With
Call 月更新処理
End Sub
とPrivate Sub btnNext_Click()
With Worksheets("②入力")
.Range("B1").Value = .Range("B1").Value + 1
End With
Call 月更新処理
End Sub
これだと月だけ更新される
月と年を一緒に更新したい
また、ユーザーフォームのところにも月と年を表示したい
[返信 6] Re : vbaおかしい
投稿者 : クリア 投稿日時 : 2026/03/14(Sat) 18:09:02
作った人にきいた方がいいんじゃないですか
作った人にきいた方がいいんじゃないですか
[返信 7] Re : vbaおかしい
投稿者 : テ 投稿日時 : 2026/03/16(Mon) 07:13:35
Sub 前月()
Dim ws As Worksheet: Set ws = Worksheets("②入力")
ws.Range("B2").Value = ws.Range("B2").Value - 1
If ws.Range("B2").Value < 1 Then ws.Range("B2").Value = 12
Call 月変更更新
これかな
Option Explicit
'========================================
' ■ メイン処理（4月〜3月集計対応）
'========================================
Sub 月変更更新()
'-----------------------------
' 高速化
'-----------------------------
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'-----------------------------
' 自動バックアップ
'-----------------------------
Call 自動バックアップ
'-----------------------------
' シート設定
'-----------------------------
Dim wsIn As Worksheet, wsSum As Worksheet, wsExt As Worksheet
Dim wbExt As Workbook
Dim dict As Object
Set wsIn = Worksheets("②入力")
Set wsSum = Worksheets("③集計")
Set dict = CreateObject("Scripting.Dictionary")
'-----------------------------
' 外部シートから班取得
'-----------------------------
Set wbExt = Workbooks.Open(ThisWorkbook.Path & "\外部データ.xlsx")
Set wsExt = wbExt.Worksheets(1)
Dim r As Long, han As Long, colorVal As Long
' 左右両方の表 1〜17 / 18〜31 日
For r = 5 To 35
colorVal = wsExt.Cells(r, 3).Interior.Color
Select Case colorVal
Case RGB(68, 114, 196): han = 1
Case RGB(237, 125, 49): han = 2
Case RGB(112, 48, 160): han = 3
Case RGB(255, 192, 0): han = 4
Case RGB(0, 176, 240): han = 5
Case RGB(0, 176, 80): han = 6
Case Else: han = 0
End Select
' 左右両方に反映
wsIn.Cells(r, 3).Value = han '左
wsIn.Cells(r, 7).Value = han '右
Next r
wbExt.Close False
'-----------------------------
' 名前辞書作成（高速検索）
'-----------------------------
Dim name As String, rowN As Long
For r = 2 To 200
If wsSum.Cells(r, 2).Value <> "" Then
dict(wsSum.Cells(r, 2).Value) = r
End If
Next r
'-----------------------------
' 月取得
'-----------------------------
Dim m As Integer, col As Long
m = wsIn.Range("B2").Value
col = (m - 4) * 3 + 6
If m < 4 Then col = (m + 8) * 3 + 6
'-----------------------------
' 月データリセット
'-----------------------------
wsSum.Range(wsSum.Cells(2, col), wsSum.Cells(200, col + 2)).Value = 0
'-----------------------------
' 月集計
'-----------------------------
Dim youbi As String
Dim tue As Long, sat As Long, allD As Long
Dim c As Long
' 左右両方の表を集計
For r = 5 To 35
Dim i As Long
For i = 2 To 6 Step 4 ' 左=2,右=6（曜日列）
name = wsIn.Cells(r, i + 2).Value ' 担当列
youbi = wsIn.Cells(r, i).Value ' 曜日列
han = wsIn.Cells(r, i - 1).Value ' 班列
If name <> "" And han >= 1 And han <= 3 Then
If dict.exists(name) Then
rowN = dict(name)
If InStr(youbi, "火") > 0 Then wsSum.Cells(rowN, col).Value = wsSum.Cells(rowN, col).Value + 1
If InStr(youbi, "土") > 0 Then wsSum.Cells(rowN, col + 1).Value = wsSum.Cells(rowN, col + 1).Value + 1
wsSum.Cells(rowN, col + 2).Value = wsSum.Cells(rowN, col + 2).Value + 1
End If
End If
Next i
Next r
'-----------------------------
' 年集計（4月〜3月）
'-----------------------------
For r = 2 To 200
tue = 0: sat = 0: allD = 0
For c = 6 To 42 Step 3
tue = tue + wsSum.Cells(r, c).Value
sat = sat + wsSum.Cells(r, c + 1).Value
allD = allD + wsSum.Cells(r, c + 2).Value
Next c
wsSum.Cells(r, 3).Value = tue
wsSum.Cells(r, 4).Value = sat
wsSum.Cells(r, 5).Value = allD
Next r
'-----------------------------
' 高速化解除
'-----------------------------
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
'========================================
' ■ 月送りボタン
'========================================
Sub 次月()
Dim ws As Worksheet: Set ws = Worksheets("②入力")
ws.Range("B2").Value = ws.Range("B2").Value + 1
If ws.Range("B2").Value > 12 Then ws.Range("B2").Value = 1
Call 月変更更新
End Sub
Sub 前月()
Dim ws As Worksheet: Set ws = Worksheets("②入力")
ws.Range("B2").Value = ws.Range("B2").Value - 1
If ws.Range("B2").Value < 1 Then ws.Range("B2").Value = 12
Call 月変更更新
これかな
[返信 8] Re : vbaおかしい
投稿者 : テ 投稿日時 : 2026/03/16(Mon) 19:09:52
これをユーザーフォームにしてみて
Private Sub btn前月_Click()
Dim ws As Worksheet
Dim m As Long
Dim y As Long
Set ws = Worksheets("②入力")
m = ws.Range("B2").Value
y = ws.Range("A1").Value
m = m - 1
If m < 1 Then
m = 12
y = y - 1
End If
ws.Range("B2").Value = m
ws.Range("A1").Value = y
Call 月変更更新_最速
Call 年月表示
Call Excel表示
End Sub
Private Sub btn前月_Click()
Dim ws As Worksheet
Dim m As Long
Dim y As Long
Set ws = Worksheets("②入力")
m = ws.Range("B2").Value
y = ws.Range("A1").Value
m = m - 1
If m < 1 Then
m = 12
y = y - 1
End If
ws.Range("B2").Value = m
ws.Range("A1").Value = y
Call 月変更更新_最速
Call 年月表示
Call Excel表示
End Sub
Sub Excel表示()
Dim arr
arr = Worksheets("②入力").Range("A5:H35").Value
lstExcel.ColumnCount = 8
lstExcel.List = arr
End Sub
Sub 年月表示()
Dim y As Long
Dim m As Long
With Worksheets("②入力")
y = .Range("A1").Value
m = .Range("B2").Value
End With
lbl年月.Caption = y & " 年 " & m & " 月"
End Sub
Sub フォーム位置固定()
Dim x As Double
Dim y As Double
x = ActiveWindow.PointsToScreenPixelsX(Range("AA10").Left)
y = ActiveWindow.PointsToScreenPixelsY(Range("AA10").Top)
Me.Left = x
Me.Top = y
End Sub
Private Sub UserForm_Initialize()
Call フォーム位置固定
Call 年月表示
Call Excel表示
End Sub
これをユーザーフォームにしてみて
[返信 9] Re : vbaおかしい
投稿者 : テ 投稿日時 : 2026/03/16(Mon) 19:09:52
これをユーザーフォームにしてみて
Private Sub btn前月_Click()
Dim ws As Worksheet
Dim m As Long
Dim y As Long
Set ws = Worksheets("②入力")
m = ws.Range("B2").Value
y = ws.Range("A1").Value
m = m - 1
If m < 1 Then
m = 12
y = y - 1
End If
ws.Range("B2").Value = m
ws.Range("A1").Value = y
Call 月変更更新_最速
Call 年月表示
Call Excel表示
End Sub
Private Sub btn前月_Click()
Dim ws As Worksheet
Dim m As Long
Dim y As Long
Set ws = Worksheets("②入力")
m = ws.Range("B2").Value
y = ws.Range("A1").Value
m = m - 1
If m < 1 Then
m = 12
y = y - 1
End If
ws.Range("B2").Value = m
ws.Range("A1").Value = y
Call 月変更更新_最速
Call 年月表示
Call Excel表示
End Sub
Sub Excel表示()
Dim arr
arr = Worksheets("②入力").Range("A5:H35").Value
lstExcel.ColumnCount = 8
lstExcel.List = arr
End Sub
Sub 年月表示()
Dim y As Long
Dim m As Long
With Worksheets("②入力")
y = .Range("A1").Value
m = .Range("B2").Value
End With
lbl年月.Caption = y & " 年 " & m & " 月"
End Sub
Sub フォーム位置固定()
Dim x As Double
Dim y As Double
x = ActiveWindow.PointsToScreenPixelsX(Range("AA10").Left)
y = ActiveWindow.PointsToScreenPixelsY(Range("AA10").Top)
Me.Left = x
Me.Top = y
End Sub
Private Sub UserForm_Initialize()
Call フォーム位置固定
Call 年月表示
Call Excel表示
End Sub
これをユーザーフォームにしてみて
[返信 10] Re : vbaおかしい
投稿者 : テ 投稿日時 : 2026/03/17(Tue) 00:29:37
Option Explicit
Sub 月変更更新_神高速()
Dim wsIn As Worksheet, wsSum As Worksheet
Dim wbExt As Workbook, wsExt As Worksheet
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Set wsIn = Worksheets("②入力")
Set wsSum = Worksheets("③集計")
'===========================
' 外部シート班番号反映（絶対条件）
'===========================
Dim arrHan(1 To 6) As Long
Dim r As Long, han As Long, colorVal As Long
For han = 1 To 6
arrHan(han) = wsIn.Cells(1, 4 + han).Value
Next han
Set wbExt = Workbooks.Open(ThisWorkbook.Path & "\外部データ.xlsx")
Set wsExt = wbExt.Worksheets(1)
Dim arrExt As Variant
arrExt = wsExt.Range("C5:C35").Value
Dim arrIn As Variant
arrIn = wsIn.Range("C5:H35").Value '班番号と名前列
For r = 1 To UBound(arrExt, 1)
Select Case wsExt.Cells(r + 4, 3).Interior.Color
Case RGB(68, 114, 196): han = arrHan(1)
Case RGB(237, 125, 49): han = arrHan(2)
Case RGB(112, 48, 160): han = arrHan(3)
Case RGB(255, 192, 0): han = arrHan(4)
Case RGB(0, 176, 240): han = arrHan(5)
Case RGB(0, 176, 80): han = arrHan(6)
Case Else: han = 0
End Select
arrIn(r, 1) = han ' C列
arrIn(r, 5) = han ' G列
Next r
wsIn.Range("C5:H35").Value = arrIn
wbExt.Close False
'===========================
' 名前辞書作成
'===========================
Dim arrSumNames As Variant
arrSumNames = wsSum.Range("B2:B200").Value
For r = 1 To UBound(arrSumNames, 1)
If arrSumNames(r, 1) <> "" Then dict(arrSumNames(r, 1)) = r
Next r
'===========================
' 月列計算
'===========================
Dim m As Long, col As Long
m = wsIn.Range("B2").Value
col = (m - 4) * 3 + 6
If m < 4 Then col = (m + 8) * 3 + 6
' 月データリセット
wsSum.Range(wsSum.Cells(2, col), wsSum.Cells(200, col + 2)).Value = 0
'===========================
' 月集計
'===========================
Dim arrOut() As Variant
arrOut = wsSum.Range(wsSum.Cells(2, col), wsSum.Cells(200, col + 2)).Value
Dim name As String, youbi As String, tmpRow As Long
Dim i As Long, j As Long
For r = 1 To UBound(arrIn, 1)
For i = 1 To 6 Step 4 ' 左C列/G列
name = arrIn(r, i + 1)
youbi = arrIn(r, i)
han = arrIn(r, i)
If name <> "" And han >= 1 And han <= 6 Then
If dict.exists(name) Then
tmpRow = dict(name)
' 曜日カウント
If InStr(youbi, "火") > 0 Then arrOut(tmpRow, 1) = arrOut(tmpRow, 1) + 1
If InStr(youbi, "土") > 0 Then arrOut(tmpRow, 2) = arrOut(tmpRow, 2) + 1
arrOut(tmpRow, 3) = arrOut(tmpRow, 3) + 1
End If
End If
Next i
Next r
wsSum.Range(wsSum.Cells(2, col), wsSum.Cells(200, col + 2)).Value = arrOut
'===========================
' 年集計（配列内計算）
'===========================
Dim arrYear As Variant
arrYear = wsSum.Range("C2:AP200").Value
Dim sumTue As Long, sumSat As Long, sumAll As Long
For r = 1 To UBound(arrYear, 1)
sumTue = 0: sumSat = 0: sumAll = 0
For i = 1 To 37 Step 3
sumTue = sumTue + arrYear(r, i)
sumSat = sumSat + arrYear(r, i + 1)
sumAll = sumAll + arrYear(r, i + 2)
Next i
arrYear(r, 1) = sumTue
arrYear(r, 2) = sumSat
arrYear(r, 3) = sumAll
Next r
wsSum.Range("C2:E200").Value = arrYear
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
[返信 11] Re : vbaおかしい
投稿者 : テ 投稿日時 : 2026/03/17(Tue) 07:23:11
Option Explicit
Sub 月変更更新_安全神高速()
Dim wsIn As Worksheet, wsSum As Worksheet
Dim wbExt As Workbook, wsExt As Worksheet
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim arrHan(1 To 6) As Long
Dim arrIn As Variant, arrExt As Variant, arrOut() As Variant, arrYear As Variant
Dim r As Long, han As Long, i As Long, tmpRow As Long
Dim m As Long, col As Long
Dim name As String, youbi As String
'-----------------------------
' 高速化設定
'-----------------------------
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'-----------------------------
' シート設定
'-----------------------------
Set wsIn = Worksheets("②入力")
Set wsSum = Worksheets("③集計")
'===========================
' arrHan(1〜6) = E1〜E6 に格納
'===========================
For han = 1 To 6
arrHan(han) = wsIn.Cells(1, "E").Offset(0, han - 1).Value
Next han
'===========================
' 外部シート班番号反映
'===========================
Set wbExt = Workbooks.Open(ThisWorkbook.Path & "\外部データ.xlsx")
Set wsExt = wbExt.Worksheets(1)
arrExt = wsExt.Range("C5:C35").Value
arrIn = wsIn.Range("C5:H35").Value ' 入力シート配列
For r = 1 To UBound(arrExt, 1)
Select Case wsExt.Cells(r + 4, 3).Interior.Color
Case RGB(68, 114, 196): han = arrHan(1)
Case RGB(237, 125, 49): han = arrHan(2)
Case RGB(112, 48, 160): han = arrHan(3)
Case RGB(255, 192, 0): han = arrHan(4)
Case RGB(0, 176, 240): han = arrHan(5)
Case RGB(0, 176, 80): han = arrHan(6)
Case Else: han = 0
End Select
arrIn(r, 1) = han ' C列
arrIn(r, 5) = han ' G列
Next r
wsIn.Range("C5:H35").Value = arrIn
wbExt.Close False
'===========================
' 名前辞書作成
'===========================
Dim arrSumNames As Variant
arrSumNames = wsSum.Range("B2:B200").Value
For r = 1 To UBound(arrSumNames, 1)
If arrSumNames(r, 1) <> "" Then dict(arrSumNames(r, 1)) = r
Next r
'===========================
' 月列計算
'===========================
m = wsIn.Range("B2").Value
col = (m - 4) * 3 + 6
If m < 4 Then col = (m + 8) * 3 + 6
' 月データリセット
wsSum.Range(wsSum.Cells(2, col), wsSum.Cells(200, col + 2)).Value = 0
arrOut = wsSum.Range(wsSum.Cells(2, col), wsSum.Cells(200, col + 2)).Value
'===========================
' 月集計
'===========================
For r = 1 To UBound(arrIn, 1)
For i = 1 To 6 Step 4 ' C列/G列
name = arrIn(r, i + 1)
youbi = arrIn(r, i)
han = arrIn(r, i)
If name <> "" And han >= 1 And han <= 6 Then
If dict.exists(name) Then
tmpRow = dict(name)
If InStr(youbi, "火") > 0 Then arrOut(tmpRow, 1) = arrOut(tmpRow, 1) + 1
If InStr(youbi, "土") > 0 Then arrOut(tmpRow, 2) = arrOut(tmpRow, 2) + 1
arrOut(tmpRow, 3) = arrOut(tmpRow, 3) + 1
End If
End If
Next i
Next r
wsSum.Range(wsSum.Cells(2, col), wsSum.Cells(200, col + 2)).Value = arrOut
'===========================
' 年集計（配列内計算）
'===========================
arrYear = wsSum.Range("C2:AP200").Value
Dim sumTue As Long, sumSat As Long, sumAll As Long
For r = 1 To UBound(arrYear, 1)
sumTue = 0: sumSat = 0: sumAll = 0
For i = 1 To 37 Step 3
sumTue = sumTue + arrYear(r, i)
sumSat = sumSat + arrYear(r, i + 1)
sumAll = sumAll + arrYear(r, i + 2)
Next i
arrYear(r, 1) = sumTue
arrYear(r, 2) = sumSat
arrYear(r, 3) = sumAll
Next r
wsSum.Range("C2:E200").Value = arrYear
'-----------------------------
' 高速化解除
'-----------------------------
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
MsgBox "月変更更新 完了（arrHanはE1〜E6を反映済み）", vbInformation
End Sub
[返信 12] Re : vbaおかしい
投稿者 : テ 投稿日時 : 2026/03/17(Tue) 07:33:12
Option Explicit
Sub 月変更更新_安全神高速()
'=============================
' 変数宣言
'=============================
Dim wsIn As Worksheet, wsSum As Worksheet ' 入力シートと集計シート
Dim wbExt As Workbook, wsExt As Worksheet ' 外部データブックとシート
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary") ' 名前辞書
Dim arrHan(1 To 6) As Long ' 班番号配列（E1〜E6）
Dim arrIn As Variant, arrExt As Variant ' 入力シート配列・外部シート配列
Dim arrOut() As Variant, arrYear As Variant ' 月集計・年集計配列
Dim r As Long, han As Long, i As Long, tmpRow As Long
Dim m As Long, col As Long
Dim name As String, youbi As String
'=============================
' 高速化設定（画面更新・イベント停止・計算停止）
'=============================
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'=============================
' シート設定
'=============================
Set wsIn = Worksheets("②入力")
Set wsSum = Worksheets("③集計")
'=============================
' arrHan(1〜6) に E1〜E6 の班番号を格納
'=============================
' E1〜E6 の班番号を配列に入れることで、外部色判定時にすぐ班番号を取得可能
For han = 1 To 6
arrHan(han) = wsIn.Cells(1, "E").Offset(0, han - 1).Value
Next han
'=============================
' 外部シートの班番号を入力シートに反映
'=============================
Set wbExt = Workbooks.Open(ThisWorkbook.Path & "\外部データ.xlsx")
Set wsExt = wbExt.Worksheets(1)
' 外部シートのデータを配列に読み込み（C5:C35）
arrExt = wsExt.Range("C5:C35").Value
' 入力シートの班番号・名前列を配列に読み込み（C5:H35）
arrIn = wsIn.Range("C5:H35").Value
' 外部シートの色に応じて班番号を設定
For r = 1 To UBound(arrExt, 1)
Select Case wsExt.Cells(r + 4, 3).Interior.Color
Case RGB(68, 114, 196): han = arrHan(1) ' 青 → E1
Case RGB(237, 125, 49): han = arrHan(2) ' オレンジ → E2
Case RGB(112, 48, 160): han = arrHan(3) ' 紫 → E3
Case RGB(255, 192, 0): han = arrHan(4) ' 黄 → E4
Case RGB(0, 176, 240): han = arrHan(5) ' 水色 → E5
Case RGB(0, 176, 80): han = arrHan(6) ' 緑 → E6
Case Else: han = 0 ' 色なしまたは不明
End Select
' 入力シート配列に班番号を反映
arrIn(r, 1) = han ' C列
arrIn(r, 5) = han ' G列
Next r
' 配列から入力シートに書き戻す
wsIn.Range("C5:H35").Value = arrIn
' 外部データブックは保存せずに閉じる
wbExt.Close False
'=============================
' 名前辞書作成（集計シート B2:B200）
'=============================
' 名前をキー、行番号を値として Dictionary に格納
Dim arrSumNames As Variant
arrSumNames = wsSum.Range("B2:B200").Value
For r = 1 To UBound(arrSumNames, 1)
If arrSumNames(r, 1) <> "" Then dict(arrSumNames(r, 1)) = r
Next r
'=============================
' 月列計算
'=============================
m = wsIn.Range("B2").Value
col = (m - 4) * 3 + 6 ' 4月〜12月
If m < 4 Then col = (m + 8) * 3 + 6 ' 1月〜3月
' 月データリセット（配列に読み込む）
wsSum.Range(wsSum.Cells(2, col), wsSum.Cells(200, col + 2)).Value = 0
arrOut = wsSum.Range(wsSum.Cells(2, col), wsSum.Cells(200, col + 2)).Value
'=============================
' 月集計
'=============================
' 入力シート配列を走査して、曜日ごとに集計
For r = 1 To UBound(arrIn, 1)
For i = 1 To 6 Step 4 ' C列/G列 の左側と右側
name = arrIn(r, i + 1)
youbi = arrIn(r, i)
han = arrIn(r, i)
If name <> "" And han >= 1 And han <= 6 Then
If dict.exists(name) Then
tmpRow = dict(name)
' 火曜日・土曜日・合計をカウント
If InStr(youbi, "火") > 0 Then arrOut(tmpRow, 1) = arrOut(tmpRow, 1) + 1
If InStr(youbi, "土") > 0 Then arrOut(tmpRow, 2) = arrOut(tmpRow, 2) + 1
arrOut(tmpRow, 3) = arrOut(tmpRow, 3) + 1
End If
End If
Next i
Next r
' 配列をシートに書き戻す
wsSum.Range(wsSum.Cells(2, col), wsSum.Cells(200, col + 2)).Value = arrOut
'=============================
' 年集計（配列内計算）
'=============================
arrYear = wsSum.Range("C2:AP200").Value
Dim sumTue As Long, sumSat As Long, sumAll As Long
For r = 1 To UBound(arrYear, 1)
sumTue = 0: sumSat = 0: sumAll = 0
For i = 1 To 37 Step 3
sumTue = sumTue + arrYear(r, i)
sumSat = sumSat + arrYear(r, i + 1)
sumAll = sumAll + arrYear(r, i + 2)
Next i
' 集計結果を C列〜E列に格納
arrYear(r, 1) = sumTue
arrYear(r, 2) = sumSat
arrYear(r, 3) = sumAll
Next r
wsSum.Range("C2:E200").Value = arrYear
'=============================
' 高速化解除
'=============================
Application.ScreenUpdating = True
Application.EnableEvents = True
…
これは詳しいコメント入り
Option Explicit
Sub 月変更更新_安全神高速()
'=============================
' 変数宣言
'=============================
Dim wsIn As Worksheet, wsSum As Worksheet ' 入力シートと集計シート
Dim wbExt As Workbook, wsExt As Worksheet ' 外部データブックとシート
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary") ' 名前辞書
Dim arrHan(1 To 6) As Long ' 班番号配列（E1〜E6）
Dim arrIn As Variant, arrExt As Variant ' 入力シート配列・外部シート配列
Dim arrOut() As Variant, arrYear As Variant ' 月集計・年集計配列
Dim r As Long, han As Long, i As Long, tmpRow As Long
Dim m As Long, col As Long
Dim name As String, youbi As String
'=============================
' 高速化設定（画面更新・イベント停止・計算停止）
'=============================
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'=============================
' シート設定
'=============================
Set wsIn = Worksheets("②入力")
Set wsSum = Worksheets("③集計")
'=============================
' arrHan(1〜6) に E1〜E6 の班番号を格納
'=============================
' E1〜E6 の班番号を配列に入れることで、外部色判定時にすぐ班番号を取得可能
For han = 1 To 6
arrHan(han) = wsIn.Cells(1, "E").Offset(0, han - 1).Value
Next han
'=============================
' 外部シートの班番号を入力シートに反映
'=============================
Set wbExt = Workbooks.Open(ThisWorkbook.Path & "\外部データ.xlsx")
Set wsExt = wbExt.Worksheets(1)
' 外部シートのデータを配列に読み込み（C5:C35）
arrExt = wsExt.Range("C5:C35").Value
' 入力シートの班番号・名前列を配列に読み込み（C5:H35）
arrIn = wsIn.Range("C5:H35").Value
' 外部シートの色に応じて班番号を設定
For r = 1 To UBound(arrExt, 1)
Select Case wsExt.Cells(r + 4, 3).Interior.Color
Case RGB(68, 114, 196): han = arrHan(1) ' 青 → E1
Case RGB(237, 125, 49): han = arrHan(2) ' オレンジ → E2
Case RGB(112, 48, 160): han = arrHan(3) ' 紫 → E3
Case RGB(255, 192, 0): han = arrHan(4) ' 黄 → E4
Case RGB(0, 176, 240): han = arrHan(5) ' 水色 → E5
Case RGB(0, 176, 80): han = arrHan(6) ' 緑 → E6
Case Else: han = 0 ' 色なしまたは不明
End Select
' 入力シート配列に班番号を反映
arrIn(r, 1) = han ' C列
arrIn(r, 5) = han ' G列
Next r
' 配列から入力シートに書き戻す
wsIn.Range("C5:H35").Value = arrIn
' 外部データブックは保存せずに閉じる
wbExt.Close False
'=============================
' 名前辞書作成（集計シート B2:B200）
'=============================
' 名前をキー、行番号を値として Dictionary に格納
Dim arrSumNames As Variant
arrSumNames = wsSum.Range("B2:B200").Value
For r = 1 To UBound(arrSumNames, 1)
If arrSumNames(r, 1) <> "" Then dict(arrSumNames(r, 1)) = r
Next r
'=============================
' 月列計算
'=============================
m = wsIn.Range("B2").Value
col = (m - 4) * 3 + 6 ' 4月〜12月
If m < 4 Then col = (m + 8) * 3 + 6 ' 1月〜3月
' 月データリセット（配列に読み込む）
wsSum.Range(wsSum.Cells(2, col), wsSum.Cells(200, col + 2)).Value = 0
arrOut = wsSum.Range(wsSum.Cells(2, col), wsSum.Cells(200, col + 2)).Value
'=============================
' 月集計
'=============================
' 入力シート配列を走査して、曜日ごとに集計
For r = 1 To UBound(arrIn, 1)
For i = 1 To 6 Step 4 ' C列/G列 の左側と右側
name = arrIn(r, i + 1)
youbi = arrIn(r, i)
han = arrIn(r, i)
If name <> "" And han >= 1 And han <= 6 Then
If dict.exists(name) Then
tmpRow = dict(name)
' 火曜日・土曜日・合計をカウント
If InStr(youbi, "火") > 0 Then arrOut(tmpRow, 1) = arrOut(tmpRow, 1) + 1
If InStr(youbi, "土") > 0 Then arrOut(tmpRow, 2) = arrOut(tmpRow, 2) + 1
arrOut(tmpRow, 3) = arrOut(tmpRow, 3) + 1
End If
End If
Next i
Next r
' 配列をシートに書き戻す
wsSum.Range(wsSum.Cells(2, col), wsSum.Cells(200, col + 2)).Value = arrOut
'=============================
' 年集計（配列内計算）
'=============================
arrYear = wsSum.Range("C2:AP200").Value
Dim sumTue As Long, sumSat As Long, sumAll As Long
For r = 1 To UBound(arrYear, 1)
sumTue = 0: sumSat = 0: sumAll = 0
For i = 1 To 37 Step 3
sumTue = sumTue + arrYear(r, i)
sumSat = sumSat + arrYear(r, i + 1)
sumAll = sumAll + arrYear(r, i + 2)
Next i
' 集計結果を C列〜E列に格納
arrYear(r, 1) = sumTue
arrYear(r, 2) = sumSat
arrYear(r, 3) = sumAll
Next r
wsSum.Range("C2:E200").Value = arrYear
'=============================
' 高速化解除
'=============================
Application.ScreenUpdating = True
Application.EnableEvents = True
…
これは詳しいコメント入り
[返信 13] Re : vbaおかしい
投稿者 : データ 投稿日時 : 2026/03/17(Tue) 12:21:13
'========================
' 前月ボタン
'========================
Private Sub btn前月_Click()
Dim ws As Worksheet
Dim y As Long, m As Long
Set ws = Worksheets("②入力")
y = ws.Range("A1").Value
m = ws.Range("B2").Value
m = m - 1
If m < 1 Then
m = 12
y = y - 1
End If
ws.Range("A1").Value = y
ws.Range("B2").Value = m
' 月変更更新マクロを呼ぶ
月変更更新_最速
' UserForm表示更新
年月表示
Excel表示
End Sub
'========================
' 翌月ボタン
'========================
Private Sub btn翌月_Click()
Dim ws As Worksheet
Dim y As Long, m As Long
Set ws = Worksheets("②入力")
y = ws.Range("A1").Value
m = ws.Range("B2").Value
m = m + 1
If m > 12 Then
m = 1
y = y + 1
End If
ws.Range("A1").Value = y
ws.Range("B2").Value = m
' 月変更更新マクロを呼ぶ
月変更更新_最速
' UserForm表示更新
年月表示
Excel表示
End Sub
'========================
' 年月表示用
'========================
Sub 年月表示()
Dim ws As Worksheet
Set ws = Worksheets("②入力")
lbl年月.Caption = ws.Range("A1").Value & " 年 " & ws.Range("B2").Value & " 月"
End Sub
'========================
' Excelデータ表示用
'========================
Sub Excel表示()
Dim ws As Worksheet
Dim arr As Variant
Set ws = Worksheets("②入力")
arr = ws.Range("A5:H35").Value
With Me.lstExcel
.ColumnCount = 8
.List = arr
End With
End Sub
'========================
' フォーム位置固定
'========================
Sub フォーム位置固定()
Dim x As Double, y As Double
With Worksheets("②入力").Range("AA10")
x = ActiveWindow.PointsToScreenPixelsX(.Left)
y = ActiveWindow.PointsToScreenPixelsY(.Top)
End With
Me.Left = x
Me.Top = y
End Sub
'========================
' UserForm初期化
'========================
Private Sub UserForm_Initialize()
フォーム位置固定
年月表示
Excel表示
End Sub
前の絶対エラーが出るよ[返信 14] Re : vbaおかしい
投稿者 : MDQ 投稿日時 : 2026/03/17(Tue) 13:54:05
'===========================
' arrHan(1〜6) = E1〜E6 に格納
'===========================
For han = 1 To 6
arrHan(han) = wsIn.Cells(1, "E").Offset(0, han - 1).Value
Next han
E1～E6をA21からA26に変更
班が飛んでいても大丈夫に変更
班の色は決まっていて班の番号変更あり
'===========================
' arrHan(1〜6) = E1〜E6 に格納
'===========================
For han = 1 To 6
arrHan(han) = wsIn.Cells(1, "E").Offset(0, han - 1).Value
Next han
E1～E6をA21からA26に変更
班が飛んでいても大丈夫に変更
班の色は決まっていて班の番号変更あり
[返信 15] Re : vbaおかしい
投稿者 : MDQ 投稿日時 : 2026/03/17(Tue) 14:22:24
これだとダメだったので
この下のプログラムを参考にお願いします
年と月を表示ユーザーフォームと入力シートに表示もダメでした
表示をする際に年は今年から始まるものとする
VBAコード
「翌月」に更新するVBAコードです。
'========================
' 前月ボタン
'========================
Private Sub btn前月_Click()
Dim ws As Worksheet
Dim y As Long, m As Long
Set ws = Worksheets("②入力")
y = ws.Range("A1").Value
m = ws.Range("B2").Value
m = m - 1
If m < 1 Then
m = 12
y = y - 1
End If
ws.Range("A1").Value = y
ws.Range("B2").Value = m
' 月変更更新マクロを呼ぶ
月変更更新_最速
' UserForm表示更新
年月表示
Excel表示
End Sub
'========================
' 翌月ボタン
'========================
Private Sub btn翌月_Click()
Dim ws As Worksheet
Dim y As Long, m As Long
Set ws = Worksheets("②入力")
y = ws.Range("A1").Value
m = ws.Range("B2").Value
m = m + 1
If m > 12 Then
m = 1
y = y + 1
End If
ws.Range("A1").Value = y
ws.Range("B2").Value = m
' 月変更更新マクロを呼ぶ
月変更更新_最速
' UserForm表示更新
年月表示
Excel表示
End Sub
'========================
' 年月表示用
'========================
Sub 年月表示()
Dim ws As Worksheet
Set ws = Worksheets("②入力")
lbl年月.Caption = ws.Range("A1").Value & " 年 " & ws.Range("B2").Value & " 月"
End Sub
'========================
' Excelデータ表示用
'========================
Sub Excel表示()
Dim ws As Worksheet
Dim arr As Variant
Set ws = Worksheets("②入力")
arr = ws.Range("A5:H35").Value
With Me.lstExcel
.ColumnCount = 8
.List = arr
End With
End Sub
'========================
' フォーム位置固定
'========================
Sub フォーム位置固定()
Dim x As Double, y As Double
With Worksheets("②入力").Range("AA10")
x = ActiveWindow.PointsToScreenPixelsX(.Left)
y = ActiveWindow.PointsToScreenPixelsY(.Top)
End With
Me.Left = x
Me.Top = y
End Sub
'========================
' UserForm初期化
'========================
Private Sub UserForm_Initialize()
フォーム位置固定
年月表示
Excel表示
End Sub
これだとダメだったので
この下のプログラムを参考にお願いします
年と月を表示ユーザーフォームと入力シートに表示もダメでした
表示をする際に年は今年から始まるものとする
VBAコード
「翌月」に更新するVBAコードです。
Sub NextMonth()
Dim A
'1か月進める
A = DateAdd("m", 1, DateSerial(Range("A2"), Range("A3"), 1))
Range("A2") = Year(A) '年を取得
Range("A3") = Month(A) '月を取得
End Sub
↓「先月」に更新するVBAコードです。Sub PreMonth()
Dim A
'1か月戻す
A = DateAdd("m", -1, DateSerial(Range("A2"), Range("A3"), 1))
Range("A2") = Year(A) '年を取得
Range("A3") = Month(A) '月を取得
End Sub
[返信 16] Re : vbaおかしい
投稿者 : MDQ 投稿日時 : 2026/03/17(Tue) 16:34:13
'===========================
' arrHan(1〜6) = E1〜E6 に格納
'===========================
For han = 1 To 6
arrHan(han) = wsIn.Cells(1, "E").Offset(0, han - 1).Value
Next han
E1～E6をA21からA26に変更
班が飛んでいても大丈夫に変更
班の色は決まっていて班の番号変更あり
テキスト１に年＝S6 テキスト２に月＝Q6 が連結して表示する
その時にユーザーはユーザーフォームで表示しているものと
入力シートの両方をみて動作を行う
入力完了ボタンを押すと基準モジュールが動作されて
入力シートと集計シートが一致で自動でカウントを行う
集計） 列１ １年 ４月から３月
列２ 火曜日 土曜日 合計(月～日)
行１ 班 行２ メンバー(手入力)
'===========================
' arrHan(1〜6) = E1〜E6 に格納
'===========================
For han = 1 To 6
arrHan(han) = wsIn.Cells(1, "E").Offset(0, han - 1).Value
Next han
E1～E6をA21からA26に変更
班が飛んでいても大丈夫に変更
班の色は決まっていて班の番号変更あり
テキスト１に年＝S6 テキスト２に月＝Q6 が連結して表示する
その時にユーザーはユーザーフォームで表示しているものと
入力シートの両方をみて動作を行う
入力完了ボタンを押すと基準モジュールが動作されて
入力シートと集計シートが一致で自動でカウントを行う
集計） 列１ １年 ４月から３月
列２ 火曜日 土曜日 合計(月～日)
行１ 班 行２ メンバー(手入力)
[返信 17] Re : vbaおかしい
投稿者 : え 投稿日時 : 2026/03/19(Thu) 07:10:50
Public Sub 入力完了_集計_限界()
If isRunning Then Exit Sub
isRunning = True
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
On Error GoTo 終了
Dim wsIn As Worksheet, wsSum As Worksheet
Set wsIn = Worksheets("②入力")
Set wsSum = Worksheets("③集計")
Dim 月 As Long: 月 = wsIn.Range("S1").Value
Dim col As Long: col = IIf(月 >= 4, (月 - 4) * 3 + 6, (月 + 8) * 3 + 6)
'========================
' ■ 入力取得
'========================
Dim dataIn
dataIn = wsIn.Range("A5:H35").Value
'========================
' ■ key高速化（Join）
'========================
Dim key As String
key = Join(Application.Index(dataIn, 0, 1), "") _
& Join(Application.Index(dataIn, 0, 2), "") _
& Join(Application.Index(dataIn, 0, 3), "") _
& Join(Application.Index(dataIn, 0, 4), "") _
& Join(Application.Index(dataIn, 0, 5), "") _
& Join(Application.Index(dataIn, 0, 6), "") _
& Join(Application.Index(dataIn, 0, 7), "") _
& Join(Application.Index(dataIn, 0, 8), "")
If wsSum.Cells(1, col).Value = key Then GoTo 年間
'========================
' ■ Dictionaryキャッシュ
'========================
If gDict Is Nothing Then
Set gDict = CreateObject("Scripting.Dictionary")
Dim arr, i As Long
arr = wsSum.Range("B2:B200").Value
For i = 1 To UBound(arr, 1)
If arr(i, 1) <> "" Then gDict(arr(i, 1)) = i
Next
End If
Dim result(1 To 199, 1 To 3)
Dim r As Long, idx, han, youbi
For r = 1 To 31
' 左
If dataIn(r, 3) <> "" Then
If gDict.exists(dataIn(r, 3)) Then
idx = gDict(dataIn(r, 3))
han = dataIn(r, 2)
If han <> "" Then
youbi = dataIn(r, 2)
If InStr(youbi, "火") Then result(idx, 1) = result(idx, 1) + 1
If InStr(youbi, "土") Then result(idx, 2) = result(idx, 2) + 1
result(idx, 3) = result(idx, 3) + 1
End If
End If
End If
' 右
If dataIn(r, 7) <> "" Then
If gDict.exists(dataIn(r, 7)) Then
idx = gDict(dataIn(r, 7))
han = dataIn(r, 6)
If han <> "" Then
youbi = dataIn(r, 6)
If InStr(youbi, "火") Then result(idx, 1) = result(idx, 1) + 1
If InStr(youbi, "土") Then result(idx, 2) = result(idx, 2) + 1
result(idx, 3) = result(idx, 3) + 1
End If
End If
End If
Next
wsSum.Cells(2, col).Resize(199, 3).Value = result
wsSum.Cells(1, col).Value = key
年間:
'========================
' ■ 年間（そのままでも高速）
'========================
Dim mArr, sumArr(1 To 199, 1 To 3)
Dim cc As Long
mArr = wsSum.Cells(2, 6).Resize(199, 36).Value
For r = 1 To 199
For cc = 1 To 36 Step 3
sumArr(r, 1) = sumArr(r, 1) + mArr(r, cc)
sumArr(r, 2) = sumArr(r, 2) + mArr(r, cc + 1)
sumArr(r, 3) = sumArr(r, 3) + mArr(r, cc + 2)
Next
Next
wsSum.Range("C2").Resize(199, 3).Value = sumArr
終了:
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
isRunning = False
End Sub
[返信 18] Re : vbaおかしい
投稿者 : え 投稿日時 : 2026/03/19(Thu) 07:14:04
Public Sub 月変更_色変換_限界()
If isRunning Then Exit Sub
isRunning = True
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
On Error GoTo 終了
Dim wsIn As Worksheet
Set wsIn = Worksheets("②入力")
Dim 月 As Long: 月 = wsIn.Range("S1").Value
Dim 外部名 As String: 外部名 = wsIn.Range("C1").Value
If 外部名 = "" Then GoTo 終了
'========================
' ■ 外部ファイルキャッシュ
'========================
If gLastFile <> 外部名 Then
If Not gWb Is Nothing Then gWb.Close False
Dim path As String
path = ThisWorkbook.Path & "\" & 外部名 & ".xlsx"
If Dir(path) = "" Then GoTo 終了
Set gWb = Workbooks.Open(path, ReadOnly:=True)
Set gWsExt = gWb.Sheets(外部名)
gLastFile = 外部名
End If
'========================
' ■ 月位置
'========================
Dim startRow As Long
startRow = 5 + IIf(月 >= 4, 月 - 4, 月 + 8) * 31
'========================
' ■ 色取得（爆速）
'========================
Dim i As Long, colVal As Long
Dim arrHan(1 To 31, 1 To 1)
' 班番号
Dim h1, h2, h3, h4, h5, h6
h1 = wsIn.Cells(21, 1).Value
h2 = wsIn.Cells(22, 1).Value
h3 = wsIn.Cells(23, 1).Value
h4 = wsIn.Cells(24, 1).Value
h5 = wsIn.Cells(25, 1).Value
h6 = wsIn.Cells(26, 1).Value
For i = 1 To 31
colVal = gWsExt.Cells(startRow + i - 1, 3).Interior.Color
Select Case colVal
Case RGB(68,114,196): arrHan(i, 1) = h1
Case RGB(237,125,49): arrHan(i, 1) = h2
Case RGB(112,48,160): arrHan(i, 1) = h3
Case RGB(255,192,0): arrHan(i, 1) = h4
Case RGB(0,176,240): arrHan(i, 1) = h5
Case RGB(0,176,80): arrHan(i, 1) = h6
Case Else: arrHan(i, 1) = ""
End Select
Next
wsIn.Range("C5").Resize(31).Value = arrHan
wsIn.Range("G5").Resize(31).Value = arrHan
終了:
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
isRunning = False
End Sub
[返信 19] Re : vbaおかしい
投稿者 : え 投稿日時 : 2026/03/19(Thu) 07:18:22
Option Explicit
Private isRunning As Boolean
' キャッシュ
Private gDict As Object
Private gWb As Workbook
Private gWsExt As Worksheet
Private gLastFile As String
Option Explicit
Private isRunning As Boolean
' キャッシュ
Private gDict As Object
Private gWb As Workbook
Private gWsExt As Worksheet
Private gLastFile As String
当掲示板について
- Excel VBA に関する掲示板です。Excel VBA に関する質問や疑問、それに対する解決方法など気軽に投稿してください。
- 記事内ではHTMLのタグは使用できません。
- 記事は一度投稿すると修正できません。内容を訂正したい場合は返信で対応してください。
- Sub〜End Sub、Function〜End Function は自動的にプログラムコードとみなし、枠で囲って見やすくします。
- Excel VBA とは関係ないことや、他人が不快に思うようなことなど、管理人が適当でないと判断した記事は削除する場合があります。
スポンサーリンク
返信入力フォーム
( 処理日時 : 2026-05-08 18:29:29 )