[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『加算するように修正したい』（ヒロセ）
下記マクロなのですが、自分が書いたものではないため、どう修正すれば思い通りの動きをするのかがわかりません。
ご教示いただきたく存じます。
〔今現在マクロで出来ること〕
マクロが長いため、うまく説明できるかわかりませんが・・・
マクロがあるエクセルブックと同ファイルにある設備〜.xlsxを開いて、帳簿エクセルに書き込み
他部署からもらう設備〜.xlsxには、取得年月と開始年月が記載してあるので、取得年月の場合→国内_連結修正後シートへ、開始年月の場合→国内_計上連結修正後へ転記
BP00100FUJI
BP00101FUJI のように、枝番でわかれているものは、マクロブックで名称を指定しそちらへ転記される
〔やりたいこと〕
１．そもそも設備〜.xlsxの行を修正しないと読み込みすらしてくれないため、設備エクセルが下記の場合、どのように開始行(A11セルから)？を指定すればよいか
D6110,D6120,D6125,D6560それぞれ最終はENDですが、行数はバラバラです。
|[A] |[B] |[C] |[D] |[E] |[F] |[G] |[H] |[I] |[J] |[K] |[L] 〜 | |[Q]
[1] |D1228 |入力 | | | | | | | | | | |
[2] |単位： |0002 | |〇〇部 | | | | | | | | |
[3] |シナリオ： |8月 | |年度： |2024 | | | | | | | |
[4] |予算： |VB001 | |〇〇課 | | | | | | | | |
[5] |バージョン |1 | | | | | | | | | | |
[6] | | | | | | | | | | | | |
[7] |(単位：千円)| | | | | | | | | | | |
[8] | 管理No. | 目的 | 科目 |名称 |資産 | | |取得年月 |開始年月 | |
[9] | |コード |名称 |コード |名称 | |コード |名称 |年数 | | | |金額
[10]| | |合計 | | | | | | | | | |
[11]|BP00100FUJI |010 |新規 |0AA |(3年) |小型焼成炉 |170 |〇 |3 |2024/12 |2024/12 | |5,000
[12]|BP00101FUJI |010 |新規 |0AA |(3年) |電気炉 |170 |〇 |3 |2024/12 |2025/01 | |4,176
[13]|BP00200TANI |030 |変更 |0BA |(3年) |転写機 |170 |● |3 |2024/04 |2024/06 | |916
[14]| | | | | | | | | | | | |
[15]| | | | | | | | | | | | |
[16]| | | | | | | | | | | | |
[17]| | | | | | | | | | | | |
[18]| | | | | | | | | | | | |
[19]|END | | | | | | | | | | | |
２．枝番が同じ年月である場合、金額が上書きになってしまっているので、加算に変更したい。
以下、マクロになります。
どう修正すればやりたいことができるようになるでしょうか？
ほかに必要な情報がわからず、大変申し訳ございません。
ご質問いただければすぐに用意いたしますので、よろしくお願いいたします。
Option Explicit
Dim Folder1 As String
Dim Folder2 As String
Const Book2 As String = "帳票"
Dim RE As Object '正規表現オブジェクト
Dim ks1 As Worksheet '管理シート
Dim ks2 As Worksheet '変換結果シート
Dim k_maxrow1 As Long '管理シート最大行番号
Dim k_maxrow2 As Long '変換結果シート最大行番号
Dim ows1 As Worksheet '投資用シート
Dim ows2 As Worksheet '計上用シート
Dim dicT As Object 'ディクショナリ キー：装置名 値：予測の行番号
Dim book_count As Long '処理ブック件数
Dim sheet_count As Long '処理シート件数
Dim data_count As Long '処理データ件数
Public Sub 月度対応転記()
Dim krow1 As Long '管理シート行番号
Dim sname As String '装置名称
Dim bname As String
Dim bname2 As String '転記先ブック名
Dim bpath2 As String '転記先ブックのパス名
Dim wb1 As Workbook '転記元ブック
Dim wb2 As Workbook '転記先ブック
Dim out_mm As Long '出力月数
Application.ScreenUpdating = False
Folder1 = ThisWorkbook.Path
Folder2 = ThisWorkbook.Path
book_count = 0
sheet_count = 0
data_count = 0
Set dicT = CreateObject("Scripting.Dictionary")
Set RE = CreateObject("VBScript.RegExp")
RE.Pattern = "^\d{4}/\d{2}$"
RE.Global = True
Set ks1 = Worksheets("管理")
Set ks2 = Worksheets("変換結果")
out_mm = 0
If IsNumeric(ks1.Range("E2").Value) = True Then
out_mm = CLng(ks1.Range("E2").Value)
End If
If out_mm < 1 Or out_mm > 12 Then
MsgBox ("管理シートの出力月が不正です")
Exit Sub
End If
k_maxrow2 = 2
'転記先ブックオープン
bname2 = Book2 & ".xlsx"
bpath2 = Folder2 & "\" & bname2
Set wb2 = Workbooks.Open(bpath2)
Set ows1 = wb2.Worksheets("国内_連結修正後")
Set ows2 = wb2.Worksheets("国内_計上連結修正後")
'投資用シート、計上用シート読込
If check_out_sheet() = False Then Exit Sub
'管理シート読込及び転記先名称のチェック
k_maxrow1 = ks1.Cells(Rows.Count, "A").End(xlUp).Row
For krow1 = 2 To k_maxrow1
sname = ks1.Cells(krow1, "B").Value
If dicT(sname) = False Then
MsgBox ("管理シートの[" & sname & "]は転記先シートに存在しません")
Exit Sub
End If
Next
'転記元ブックの読込
bname = Dir(Folder1 & "\設備*.xlsx")
Application.Calculation = xlCalculationManual
Do While bname <> ""
Set wb1 = Workbooks.Open(Folder1 & "\" & bname)
If read_all_sheets(wb1) = False Then
Application.Calculation = xlCalculationAutomatic
Exit Sub
End If
wb1.Close
book_count = book_count + 1
bname = Dir()
Loop
'転記先ブックの名称を変えて保存する
Application.Calculation = xlCalculationAutomatic
bname2 = Book2 & "_" & out_mm & "月予測.xlsx"
bpath2 = Folder2 & "\" & bname2
Application.DisplayAlerts = False
wb2.SaveAs (bpath2)
Application.DisplayAlerts = True
wb2.Close
Application.ScreenUpdating = True
MsgBox ("処理完了" & vbLf & "処理ブック件数=" & book_count & vbLf & "処理シート件数=" & sheet_count & vbLf & "処理データ件数=" & data_count)
End Sub
'転記先ブックのシートチェック
Private Function check_out_sheet() As Boolean
Dim eflag As Boolean: eflag = False
Dim maxrow1 As Long
Dim maxrow2 As Long
check_out_sheet = False
maxrow1 = ows1.Cells(Rows.Count, "J").End(xlUp).Row
maxrow2 = ows2.Cells(Rows.Count, "J").End(xlUp).Row
If maxrow1 <> maxrow2 Then
MsgBox ("転記先ブックの２つのシートの行数が不一致です")
Exit Function
End If
If maxrow1 < 14 Then eflag = True
If (maxrow1 - 10) Mod 4 <> 0 Then eflag = True
If eflag = True Then
MsgBox ("転記先ブックの２つのシートの行数が正しくありません")
Exit Function
End If
Dim wrow As Long
Dim key1 As String
Dim key2 As String
For wrow = 7 To (maxrow1 - 4) Step 4
key1 = ows1.Cells(wrow, "E").Value
key2 = ows2.Cells(wrow, "E").Value
If key1 <> key2 Then
MsgBox ("転記先ブックの２つのシートの装置名の並びが不一致です")
Exit Function
End If
Next
check_out_sheet = True
End Function
'転記元の全シートを処理する
Private Function read_all_sheets(ByRef wb1 As Workbook) As Boolean
read_all_sheets = False
Dim sarray As Variant
Dim elm As Variant
Dim result As Boolean
'処理対象となるシートの一覧
sarray = Array("D6110", "D6120", "D6125", "D6560")
For Each elm In sarray
If exist_sheet(wb1, elm) = True Then
result = read_1_sheet(wb1, elm)
If result = False Then Exit Function
sheet_count = sheet_count + 1
End If
Next
read_all_sheets = True
End Function
'指定シートがブック内にあるかチェックする
Private Function exist_sheet(ByRef wb1, ByVal elm As String)
Dim i As Long
exist_sheet = False
For i = 1 To wb1.Worksheets.Count
If UCase(elm) = UCase(wb1.Worksheets(i).Name) Then
exist_sheet = True
Exit Function
End If
Next
End Function
'1シートを処理する
Private Function read_1_sheet(ByRef wb1, ByVal elm As String)
Dim ws As Worksheet
Dim maxrow As Long
Dim wrow As Long
Dim wmonth As String
Dim sname As String
Dim t_mm As Long
Dim k_mm As Long
Dim tk_row As Long
Dim t_col As Long
Dim k_col As Long
read_1_sheet = False
Set ws = wb1.Worksheets(elm)
maxrow = ws.Cells(Rows.Count, "A").End(xlUp).Row
For wrow = 2 To maxrow
'投資月チェック
wmonth = ws.Cells(wrow, "C").Value
t_mm = get_month(wmonth)
If t_mm = 0 Then
ws.Activate
ws.Cells(wrow, "C").Select
MsgBox ("転記元シート[" & elm & "]投資月エラー:" & wmonth)
Exit Function
End If
'計上月チェック
wmonth = ws.Cells(wrow, "D").Value
k_mm = get_month(wmonth)
If k_mm = 0 Then
ws.Activate
ws.Cells(wrow, "D").Select
MsgBox ("転記元シート[" & elm & "]計上月エラー:" & wmonth)
Exit Function
End If
'装置名チェック
sname = ws.Cells(wrow, "B").Value
If dicT.exists(sname) = False Then
sname = get_sname(ws.Cells(wrow, "A").Value)
End If
'転記先の装置名が存在する場合
If sname <> "" Then
tk_row = dicT(sname)
t_col = get_column(t_mm)
k_col = get_column(k_mm)
ows1.Cells(tk_row, t_col).Value = ws.Cells(wrow, "E").Value '投資用金額
ows2.Cells(tk_row, k_col).Value = ws.Cells(wrow, "E").Value '計上用金額
data_count = data_count + 1
End If
Next
read_1_sheet = True
End Function
'月の取得 yyyy/mm からmmの数値を取得（0はエラー）
Private Function get_month(ByVal wmonth) As Long
get_month = 0
Dim w_mm As Long
If RE.test(wmonth) = False Then Exit Function
w_mm = CLng(Right(wmonth, 2))
If w_mm < 1 Or w_mm > 12 Then Exit Function
get_month = w_mm
End Function
'管理番号から転記先の装置名を取得する
Private Function get_sname(ByVal kbango As String)
Dim ptn As String
Dim wrow As Long
For wrow = 2 To k_maxrow1
ptn = ks1.Cells(wrow, "A").Value
If kbango Like ptn Then
get_sname = ks1.Cells(wrow, "B").Value
ks2.Cells(k_maxrow2, "A").Value = kbango
ks2.Cells(k_maxrow2, "B").Value = ptn
ks2.Cells(k_maxrow2, "C").Value = ks1.Cells(wrow, "B").Value
k_maxrow2 = k_maxrow2 + 1
Exit Function
End If
Next
get_sname = ""
End Function
'月数からカラム番号を取得する
Private Function get_column(ByVal mm As Long) As Long
Dim bias As Long: bias = 8
If mm < 4 Then mm = mm + 12
If mm > 9 Then bias = bias + 1
get_column = mm + bias
End Function
＜ 使用 Excel：Microsoft365、使用 OS：Windows10 ＞
コードは拝見しておりませんが、気づいたことをメモします。
最初の質問事項ですが、どのようなトライをされたのでしょうか? 表を見て気づくのは、 "管理No."があるセルをFindで検索し、そこからEndプロパティで下にジャンプしたところを開始行とする方式でしょう。 それではうまくいかないですか？ 各表の実際がわからないので、確証はありあせんが、そういう方針でトライされてはいかがですか？
二点目。上書きを加算に変更する件。 現在、 Cells(x,y).Value = v としているのであれば、 Cells(x,y).Value = Cells(x,y).Value + v とするとよいでしょう。 （xyz） 2024/08/22(木) 15:51:25
回答ありがとうございます。
トライもなにも、マクロ初心者のため以前作られたこちらのコードが動くように表を1から7行目、9から10行目、CからI列までをガッと削除しておりまして・・・
＞"管理No."があるセルをFindで検索し、そこからEndプロパティで下にジャンプしたところを開始行とする方式でしょう。
そういうやり方があるのですね。
厚かましいお願いですが、よければコードを書いていただくことは可能でしょうか？
加算にする方法ですが、コードを探したところ、そちらに当てはまりそうなものが見つかりませんでした・・・
（ヒロセ） 2024/08/22(木) 16:07:30
提示されたシートのレイアウトがコードと合っていませんし、 部分的にコードを提示することは却って混乱させるので、その積りはありません。 下記を参考にして、ご自分でトライしてください。
条件に当てはまるセルを検索する(Findメソッド） https://www.moug.net/tech/exvba/0050116.html
終端セルを参照する(Endプロパティ) https://www.moug.net/tech/exvba/0050088.html
上書きを加算に変更する件については、考え方を書いたものです。 そういうコードがあるとは申し上げていません。
他の回答者さんのコメントをお待ちください。 （xyz） 2024/08/22(木) 19:55:11
（匿名希望） 2024/08/23(金) 09:02:06
回答ありがとうございます。
出来上がってしまっているコードを部分的に改変した際、不具合が起きたときに修正が難しい、という認識で間違いないでしょうか？
いただいたURLにて勉強してみます。
匿名希望さん
ありがとうございます。
すみません、先ほど回答を見たもので・・・
たしかにそうですね、早めに返信したいと思います。
（ヒロセ） 2024/08/23(金) 09:54:20
相変わらず回答ではありませんが、コメントしておきます。
(1) > コードが動くように表を1から7行目、9から10行目、CからI列までをガッと削除しておりまして これは手作業でということですか？提示されたコードには見当たりませんが。
どのシートも同じように削除して動作するなら、必要なデータの開始行は常に11行目ということですか？ それなら検索をする必要はないですね。 シートによって可変だということなら、特別な文字列を目印にして検索するといった必要があるでしょう。
また、削除処理をやめるのであれば、行や列がズレてきますからコードの修正が必要です。 （手作業の削除処理をマクロに取り込むなら、そうした修正は不要でしょう。）
(2) 提示されたレイアウトは、処理対象の"D6110", "D6120", "D6125", "D6560"シートのうちのどれですか？
B列が装置名と言う前提でコードは書かれていると思いますが、 B列の010とか030が装置名なんですか？新規・変更のコードじゃないですか?
(3) 枝番号とだけ言われても他人にはわかりません。 管理No.（BP00100FUJIなど）の5文字目までは同一で、6文字目以降が異なるものと言うことですか? それらは必ず連続して入力されているんですか? 別のものが途中に入るということもあるんですか？ もし連続しているなら、直前のものと比較して枝番であって、対象年月(投資月、計上月）が同一なら、 上書きではなく、加算するようにすればよいでしょう。
If 直前管理No変数 と比較して枝番であるなら、
ows1.Cells(tk_row, t_col).Value = ows1.Cells(tk_row, t_col).Value + ws.Cells(wrow, "E").Value などとします。
End If
次回のために、直前管理No変数を記憶しなおす
というようなことになるでしょう。 (必ずしも連続はしていないということなら、dictinaryを使った別の仕組みが必要になるでしょう。 なお、dicTの登録処理もどこで実行しているのか不明で、読んでいて気になりました。）
勘定系の処理であれば、他人のチェックも入れながら、事前検証をしっかり実行する必要があるでしょう。 質問掲示板に相談して解決といった話じゃないと思います。 マクロ初心者ですなどということではなく、仕事であるならきちんとVBAを学習すべきだし、甘くみてはいけないでしょう。 そうした時間も取れないということなら、上司に相談して他のメンバーの助けを借りるとか、 場合によっては外注することも考えたほうがよいでしょう。
私は以上とさせていただきます。他の回答者さんからコメントがあればいいですね。 （xyz） 2024/08/23(金) 12:47:02
わざわざありがとうございます。
（１）今はガッと削除するまでを手作業、他集計をこちらのマクロでやっております。
"D6110", "D6120", "D6125", "D6560"こちらすべてのシートの開始行が11行目になります。
すべてが同じ開始行であれば、そこまで大きな修正は必要ないということでしょうか？
まずは上記コードが読めないといけないということですね・・・
（２）例にあげている表はD6120のものです。
上記コードを使用していたときはB列が装置名だったのですが、4月に部署移動があった際に提示のレイアウトになり、11行目に装置名が来るようになりました。
ですのでガッと削除する、という作業が必要になってしまい、開始行を変えることが出来たらマクロを動かすだけの作業になるのでこちらで質問した次第です。
（３）まずはどこで枝番分の数値が上書きされているかを知る必要がありますね・・
そこにxyzさんが提示してくださっているコードを入れ込むと加算になる、のでしょうか？
加算方法はコードによって違うことはないんですよね？（いろいろなパターンがあるわけではない？）
わかりやすいご説明ありがとうございました。
（ヒロセ） 2024/08/23(金) 13:14:45
１．ご提示の表が読込シートならＥ列は金額ではありませんが。また
＞＞CからI列までをガッと削除
とのことですが、それでも、L列がE列に成るだけで金額ではないようですが
C〜N までガ〜〜〜ト 。。。なら Q列がEに来るので解るのですが
私の勘違いでせうか。
２．帳票ブックの
国内_連結修正後、国内_計上連結修正後 の各シートの同じ位置に同じ枝番[詳細不明^^;]の物は
１．のシートのＱ列の金額が加算された金額を転記するのですか。
３．管理、変換結果 の各シートは。。。何の役割が。シート名等の確認だけですか
それとも他にも何か関連がありますか。
５．国内_連結修正後、国内_計上連結修正後、管理、変換結果、の各シートのレイアウト、関連性
、役割等々も教えて戴くと、コード解読の難易度が下がり多数アドバイスがあるかも
しれません。← 多分ですが。。。(￣▽￣)
m(__)m
（隠居Z） 2024/08/24(土) 17:01:04
１．＞C〜N までガ〜〜〜ト 。。。なら Q列がEに来るので解るのですが
すみません、さらにL〜Pも削除しております。
手修正後のシートはこうなっていました。
|[A] |[B] |[C] |[D] |[E]
[1] |管理No. |資産名称 |取得年月 |開始年月 |合計
[2] |BP00100FUJI |小型焼成炉 |2024/12 |2024/12 |5,000
[3] |BP00101FUJI |電気炉 |2024/12 |2025/01 |4,176
[4] |BP00200TANI |転写機 |2024/04 |2024/06 |916
[5] | | | | |
２．＞１．のシートのＱ列の金額が加算された金額を転記するのですか。
そうなります。これが現在上書きになっている部分でして、加算になるようにしたいです。
３．管理、変換結果シートは、枝番を振り分けるために使用しています。
BP0010* 小型焼成炉 のように記載し、BP00101FUJIは小型焼成炉へ転記されるようになっているようです。
５．なるほど、他資料のレイアウトもあるとアドバイスがいただきやすいのですね。
下記に提示いたしますので、見ていただけると幸いです。
【国内_連結修正後、国内_計上連結修正後シート】
※シート名以外は内容が同じものです。
※現在はP列の9176が4176のみ記載されるようになっています。
※587〜590行にはすべての合計金額がSUM関数で出されています。
|[E] |[F] |[G] |[H] |[I] |[J] |[K] |[L] 〜[Q] |[M] |[N] |[O] |[P] |[Q] |[R] |[S] |[Y] |
[6] |設備名称 |目的 |内容 |担当 | | |上期合計 |4月度〜9月度 |下期合計 |10月度 |11月度 |12月度 |1月度 |2月度 |3月度 |2024年度 |
[7] |小型焼成炉 | | | | |計画 |SUM関数 | |SUM関数 | | | | | | |SUM関数 |
[8] | | | | | |前予 | | | | | | | | | | |
[9] | | | | | |予測 | | | | | |9176 | | | | |
[10] | | | | | |実績 | | | | | | | | | | |
[11] |転写機 | | | | |計画 | | | | | | | | | | |
[12] | | | | | |前予 | | | | | | | | | | |
[13] | | | | | |予測 | | | | | | | | | | |
[14] | | | | | |実績 | | | | | | | | | | |
[15] |レーザー顕微鏡 | | | | |計画 | | | | | | | | | | |
[16] | | | | | |前予 | | | | | | | | | | |
[17] | | | | | |予測 | | | | | | | | | | |
[18] | | | | | |実績 | | | | | | | | | | |
[19] |ICP | | | | |計画 | | | | | | | | | | |
[20] | | | | | |前予 | | | | | | | | | | |
[21] | | | | | |予測 | | | | | | | | | | |
[22] | | | | | |実績 | | | | | | | | | | |
[ ] | | | | | | | | | | | | | | | | |
[ ] | | | | | | | | | | | | | | | | |
[ ] | | | | | | | | | | | | | | | | |
[ ] | | | | | | | | | | | | | | | | |
[587]| | | | | |計画 | | | | | | | | | | |
[588]| | | | | |前予 | | | | | | | | | | |
[589]| | | | | |予測 | | | | | | | | | | |
[590]| | | | | |実績 | | | | | | | | | | |
【管理シート】
|[A] |[B] |[C] |[D] |[E] |[F] |
[1] |パターン |転記先資産名称 | | |出力月 | |
[2] |BP0010* |小型焼成炉 | | |8 | |
[3] |BP0050* |レーザー顕微鏡 | | | | |
[4] |BP0060* |ICP | | | | |
[5] | | | | | | |
２
【変換結果シート】
|[A] |[B] |[C] |[D] |
[1] |管理番号 |パターン |転記先資産名称 | |
[2] |BP00101FUJI |BP0010* |小型焼成炉 | |
[3] |BP00501ENDO |BP0050* |レーザー顕微鏡 | |
[4] |BP00601mori |BP0060* |ICP | |
[5] | | | | |
（ヒロセ） 2024/08/26(月) 10:18:59
簡単な解決策
１．手作業で削除しておられる工程を別途マクロにする。[情報変換]
２．金額を転記している箇所は1箇所だと思いますので
そこを、xyz さんがご案内の様に変更する。
例 X = X + 1
Private Function read_1_sheet(ByRef wb1, ByVal elm As String) の
ows1.Cells(tk_row, t_col).Value = ws.Cells(wrow, "E").Value '投資用金額
ows2.Cells(tk_row, k_col).Value = ws.Cells(wrow, "E").Value '計上用金額
を
ows1.Cells(tk_row, t_col).Value = ows1.Cells(tk_row, t_col).Value + ws.Cells(wrow, "E").Value '投資用金額
ows2.Cells(tk_row, k_col).Value = ows2.Cells(tk_row, k_col).Value + ws.Cells(wrow, "E").Value '計上用金額
とかで。。。いけるかもしれません。。。多分。。。^^;
ダメかもしれませんので、お試の際は必ず、バックアップをお取りくださいませ。
m(__)m
（隠居Z） 2024/08/26(月) 13:19:53
ご回答ありがとうございます。
このガッと削除、の手間がなくなれば。とは思っていますが如何せん知識が足りなくて・・・
上記でxyzさんもおっしゃってますが、本格的に勉強しないといけないですね。
１．情報変換 とのことですが、これは読込位置を変えればいけるのではないか。と考えております。
ただ、ENDを入れたままにしておくとエラーになっているので、そこも修正が必要だと思っておりまして
xyzさんの「終端セルを参照する(Endプロパティ)」が必要なのかと思ってはいるのですが・・・
２．転記されているのはその部分でしたか！
提示のコードで試してみましたが、上書きされていました。
加算方法のコードはいろいろあるのでしょうか？
（ヒロセ） 2024/08/26(月) 13:40:24
追記です。
もう一度走らせたところ、上記コードで無事に加算されました。
ありがとうございます。
（ヒロセ） 2024/08/26(月) 14:01:16
普通はテストしてからご案内するのですが。。。←そのために関係無いと思われる部分まで
根掘り葉掘りお聞きしています。なにせ、大掛かりなプロジェクトみたいで、ささっと、当
方のテスト環境が構築できずにいます。^^;
手作業！ガァ〜ット。。。の部分は手作業をマクロの記録でも簡単に作成は出来ますよ。
本日は、買い物、炊事当番。。。^^;なのでまた、後日。。。現れます←よければですが
他の回答者様のご案内も合わせてお待ちくださいませ。
でわ
<< _ _ >>
（隠居Z） 2024/08/26(月) 14:27:28
提示のマクロが長いですし、また出てくるシートも多いためテストに向かないですね・・・申し訳ないです。
マクロの記録ですか、調べて出てきていたので一度そちらを試してみたいと思います。
ありがとうございます。
また来られた際にお聞きしたいこともあるので、厚かましいお願いではございますが答えられる範囲でかまいませんのでご教示いただけますと幸いです。
買い物、炊事当番頑張ってください！
（ヒロセ） 2024/08/26(月) 14:37:32
１．加算出来たのは良いのですが、この手のループ処理では何処かでブレーク処理をしないと、
加算し続け。。。間違った結果となったり、オーバーフローしたりすることが珍しくあり
ません。書き込みシートが適切な、何らかの間隔で変わるなら。。。よいかもしれませんが^^;
２．xyzさん、もご案内でしたが、連想配列の構築ロジックが見当たらないようです。なので
正確に条件比較が出来ているか解らない部分が有るかもしれません。
念入りにテストをされた方が＾＾；。。。よいかもしれません。
ここ二、三日インクスケープでイラスト書いてましたんで、ご提示のコードはほぼ
暗号状態にもどっています。。。(*_*;
詳細なご説明もいただいた事ですし、もう少しお勉強してみます。
なにせ、寄る年波で。。。手も遅く。思考力もだんだん。。。低下して
とほほ。。。← 言い訳＾＾；手が遅くにぶいのは最初からかも(*^^*)
気長にお待ちくださいませ。
他の回答者様からもアドバイスが有ると良いですね。
m(__)m
（隠居Z） 2024/08/26(月) 19:35:49
※邪魔するつもりはありませんので、隠居Zさんとのやり取りが一段落してから読みください。
■１
＞〜自分が書いたものではないため、
すでに同種のコメントがあるところですが、コードの改造をしようと思うならば 現状のコードを理解することは必須であると思います。 （ご自身で書いたのでなければなおさらです。）
＞こちらのコードが動くように表を1から7行目、9から10行目、CからI列までをガッと削除しておりまして・・・
理屈（仕様）がわかっていないコードをそのままにして、表のほうを改変するのはお勧めできません。 （単純に実行しただけでは気づかない部分で行やセルを指定している可能性が否定できないため）
＞厚かましいお願いですが、よければコードを書いていただくことは可能でしょうか？
こちらのサイトでは禁止されているわけではないので、最終的にはご自身で判断することですが、 「質問掲示板」で、丸投げ発注するのはオススメできません。
自分の手を動かしたくないのであれば、コストをかけて身元のしっかりした業者に依頼されたほうがよいでしょう。 いや、そういうことではなくて、学習する気はあるが取っ掛かりとしてコードを教えてほしいと いうことならば、まずは【ご自身】で手を付けてみて、〇〇になるとおもって、××を△△に変えたが □□になってしまうので解決法を教えてほしいなど、具体例をあげて【質問】されるとよいと思います。
■２
ざっと眺めた程度ですが、こちらの好みの部分も含めて変数（しかも、モジュールレベル）やユーザー定義関数が多用されており、わかりづらいコードになっていると思います。
やっていることはさして難しいことはしていない（とおもう）ので、作り直すことを前提にトライしてみて、詰まったら具体的に"質問"すれば有効なアドバイスがもらえるのではないかと思いました。
〜〜〜以下、眺めていて気になった部分です〜〜〜
■３
out_mm = 0
If IsNumeric(Worksheets("管理").Range("E2").Value) = True Then
out_mm = CLng(Worksheets("管理").Range("E2").Value)
End If
If out_mm < 1 Or out_mm > 12 Then
MsgBox ("管理シートの出力月が不正です")
Exit Sub
End If
↑について、管理シートのE2セルに「12.1」みたいな小数点以下を入力しない前提ですが↓でも目的は達成できると思います。
Sub 研究用01()
Dim out_mm As Long '出力月数
With Worksheets("管理").Range("E2")
Select Case .Value
Case 1 To 12
out_mm = .Value
Case Else
MsgBox "管理シートのE2セルの値「" & .Value & "」を月として評価できません"
Exit Sub
End Select
End With
End Sub
■４
Const Book2 As String = "帳票" Dim wb2 As Workbook '転記先ブック
bname2 = Book2 & ".xlsx" Folder2 = ThisWorkbook.Path bpath2 = Folder2 & "\" & bname2 Set wb2 = Workbooks.Open(bpath2)
↑は↓でよいでしょう。
Dim wb2 As Workbook '転記先ブック Set wb2 = Workbooks.Open(ThisWorkbook.Path & "\帳票.xlsx")
■５
ユーザー定義関数の「check_out_sheet」は↓のようにしたほうがわかりやすいような気がします。
'転記先ブックのシートチェック
Private Function check_out_sheet(wb2 As Workbook) As Boolean
Dim maxrow1 As Long, wrow As Long
Dim エラーメッセージ As String
With wb2.Worksheets("国内_連結修正後")
maxrow1 = .Cells(.Rows.Count, "J").End(xlUp).Row
Select Case True
Case maxrow1 < 14
エラーメッセージ = "転記先ブックの２つのシートの行数が正しくありません"
Case (maxrow1 - 10) Mod 4 <> 0
エラーメッセージ = "転記先ブックの２つのシートの行数が正しくありません"
Case maxrow1 <> wb2.Worksheets("国内_計上連結修正後").Cells(.Rows.Count, "J").End(xlUp).Row
エラーメッセージ = "転記先ブックの２つのシートの行数が不一致です"
Case Else
For wrow = 7 To maxrow1 - 4 Step 4
If .Cells(wrow, "E").Value <> wb2.Worksheets("国内_計上連結修正後").Cells(wrow, "E").Value Then
エラーメッセージ = "転記先ブックの２つのシートの装置名の並びが不一致です"
Exit For
End If
Next wrow
End Select
End With
If エラーメッセージ = "" Then
check_out_sheet = True
Else
MsgBox エラーメッセージ
check_out_sheet = False
End If
End Function
そして、↑のようにするならば、呼出し元を↓のようにしないとだめです。
'投資用シート、計上用シート読込 If check_out_sheet() = False Then Exit Sub
↓
'投資用シート、計上用シート読込 If check_out_sheet(wb2) = False Then Exit Sub
ほかにも気になる部分はありますが、いったん区切ります。
（もこな２） 2024/08/27(火) 05:22:36
炊事当番お疲れ様です、おはようございます。
１．そちらについて追加でご質問しようとしておりました。
帳簿エクセルは月ごとに更新されておりまして、今月ですと8月までの予測、実績欄は金額が固定になるマクロを別で走らせております。
ですので、9月以降は加算で問題ないのですが、月ごと（文字列ですが）で処理を変える必要がありそうだと頭を抱えている状態です・・・
２．「連想配列の構築ロジック」とやらがわからなかったため調べてみたのですが、そもそも変数・配列等がわからず今理解を深めています。
ですので、わかる範囲でまた質問にお答えしていきたいと思います。
平行して現在のコードも読めるよう、勉強はしていきます。
気長にお待ちしております。
もこな２さん
ご回答ありがとうございます。
■１
丸投げは確かによくないですね、今月バタついていたのもあり、書いていただければと思ったのですが、xyzさんからもご提案がありましたので積極的に勉強していこうと思います。
VBAに関してはこれから先もなにかとお世話になると思いますので・・・
ガッと、の部分に関してはマクロの記録で出来るようですので、記録してみて質問したいと思います。
■２
ありがとうございます。
作り直しも視野に入れて・・・なるほど、自分で一から作るのは考えていませんでした。
頭が固かったですね、現在のコードも読みつつ、自力で作ってみて理解を深めたいと思います。
■３
管理シートのE2セルには、今月（もしくは来月）を手入力しておりますので、
あっさりして少し読みやすくなったもこな２さんのコードを流用したいのですが、
これは修正というより書き直しで利用した方が良いのでしょうか？
（途中からのコードをどう置き換えればよいのかがわからず・・）
■４
これなら読めます！
調べたときに出てきたので・・ありがとうございます。
■５
転記先ブックチェックの際のマクロですね。
国内_連結修正後のみを指定されていますが、国内_計上連結修正後と比べている？のでしょうか？
（ヒロセ） 2024/08/27(火) 08:50:27
１．加算する月、加算しない月が固定でしたら、そのように条件文を
書き足してあげればよい事かと。
２．Sample mmが月だとすると
Select Case Clng(mm) ←この辺は文字列の内容により別途工夫が必要かも
Case 2,4,5,8
加算しない式
Case Else
加算する式
End Select
２月、４月、５月、８月は加算しない。その他の月は加算する。。。とか(￣▽￣；)
一案です。。。あくまで一案^^;
m(__)m
（隠居Z） 2024/08/27(火) 10:03:50
なるほど・・・
そういう書き方もあるんですね。
むしろもう予測欄を一旦0にしてしまって、そこから加算でも良いかと考えたのですが
ows1.Cells(wrow + 2, "L").Resize(2, 6).Value = 0
ows2.Cells(wrow + 2, "L").Resize(2, 6).Value = 0
ows1.Cells(wrow + 2, "S").Resize(2, 6).Value = 0
ows2.Cells(wrow + 2, "S").Resize(2, 6).Value = 0
これだと実績欄まで0になってしまい・・・
+2が原因？と考えているのですが、難しいですね。
（ヒロセ） 2024/08/27(火) 10:15:43
↑の（隠居Z） 2024/08/27(火) 10:03:50は私の勘違いかもしれません。
集計期間[範囲]を過ぎ、次の期間の集計へ移行する場合は当然合計のゼロクリア
は必要だと思います。(*^^*)
（隠居Z） 2024/08/27(火) 11:03:11
Msgbox ows1.Cells(wrow + 2, "L").Resize(2, 6),Address
のコードを差し込んだのですが、変数が定義されていないと出まして・・・
（ヒロセ） 2024/08/27(火) 11:29:05
↑ ここ ドット . でした相済みませんm(__)m
それと
加算ロジックですが。。。
無条件で加算されているような気がするのですが。[枝番が同じ]という条件文が無いような気が
するのですが、大丈夫でしょうか。ご確認を。m(__)m
すみませんでした
<< _ _ >>
（隠居Z） 2024/08/27(火) 11:46:23
For wrow = 7 To (maxrow1 - 4) Step 4
key1 = ows1.Cells(wrow, "E").Value
key2 = ows2.Cells(wrow, "E").Value
If key1 <> key2 Then
MsgBox ("転記先ブックの２つのシートの装置名の並びが不一致です")
Exit Function
End If
となっていたので、wrowでないと反応しないかと思っていました・・・
Rowでも大丈夫なのですね、勉強になります。
ありがとうございます。
隠居Zさん
ドットだけでエラーに・・なんと難しい・・
ありがとうございます。これで範囲が分かりそうです。
今まで枝番の分も反映されていたので問題ないとは思いますが、一度確認してみます。
ありがとうございます。
（ヒロセ） 2024/08/27(火) 12:29:55
メッセージボックスで確認したところ、
L9〜Q10（2シート分）「予測」「実績」の二行が範囲になっていました。
これをL9〜Q9まで、としたいのですが・・
+2を消すとL7〜Q8になるだけでしたので、アドバイスいただきたく存じます。
ows1.Cells(wrow + 2, "L").Resize(2, 6).Value = 0
ows2.Cells(wrow + 2, "L").Resize(2, 6).Value = 0
ows1.Cells(wrow + 2, "S").Resize(2, 6).Value = 0
ows2.Cells(wrow + 2, "S").Resize(2, 6).Value = 0
（ヒロセ） 2024/08/27(火) 12:36:51
とかで
なんとか。。。＾＾
でわ
（隠居Z） 2024/08/27(火) 13:47:31
０クリアになり、加算されました。
お手数をおかけしました・・よい勉強になりました。
すみません、もう一点だけお聞きしたく
下記のマクロで０クリアになっているのですが、155セルからstep4（4行おき、ということですよね？）で
「295セルまで」というコードにするにはどの部分を修正すればよいか、ご教示いただけますでしょうか？
Dim key1 As String
Dim key2 As String
For wrow = 155 To (maxrow1 - 4) Step 4
key1 = ows1.Cells(wrow, "E").Value
key2 = ows2.Cells(wrow, "E").Value
If key1 <> key2 Then
Exit Function
End If
If key1 <> "" Then
'4月〜9月を０クリア（予測、実績）
ows1.Cells(wrow + 2, "L").Resize(, 6).Value = 0
ows2.Cells(wrow + 2, "L").Resize(, 6).Value = 0
'10月〜3月を０クリア（予測、実績）
ows1.Cells(wrow + 2, "S").Resize(, 6).Value = 0
ows2.Cells(wrow + 2, "S").Resize(, 6).Value = 0
dicT(key1) = wrow + 2 '予測の行を設定
End If
Next
（ヒロセ） 2024/08/27(火) 14:08:00
For wrow = 155 To (maxrow1 - 4) Step 4
を
↓
For wrow = 155 To 295 Step 4
に
でよいとおもいます。^^;
m(__)m
（隠居Z） 2024/08/27(火) 14:38:23
なんとかうまく出来上がりました。
思った通りの動きに（今のところ）なっています。
ガッと消して・・の作業ですが、マクロの記録で出来るところとできないところがあり、
勉強しながら動かしておりますので、新しい質問としてスレ建てさせていただくかもしれません。
その時はまたお世話になるかと思います。
ありがとうございました。
（ヒロセ） 2024/08/27(火) 14:52:21
確かに、これで良いはず！＾＾。と確信が持てた時はうまく動いてます。
あらゆるパターンを想定したテストを含め、どうか、石橋を叩いて渡る、ご用心を。(*^^*)
ＶＢＡはとても便利ですが一つ間違えば思いもしない結果を出す事がございますです。
コード全体の把握と、業務の手順を全て理解するのは私では無理そうなので
これくらいしか、申し上げられませんです。
でわ
頑張ってくださいね。応援しています。(*^^*)///
（隠居Z） 2024/08/27(火) 15:11:27
■６
「月度対応転記」から部分的に取り出してちょっと改変すると↓のようになろうかとおもいます。
Sub 研究用02()
Dim krow1 As Long
Dim dicT As Object 'ディクショナリ キー：装置名 値：予測の行番号
Set dicT = CreateObject("Scripting.Dictionary")
With Worksheets("管理")
For krow1 = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
If dicT(.Cells(krow1, "B").Value) = False Then
MsgBox ("管理シートの[" & .Cells(krow1, "B").Value & "]は転記先シートに存在しません")
Exit Sub
End If
Next krow1
End With
End Sub
上記について、すでに指摘されているように「dicT」に格納されている部分が提示されていないので、想定通りなのか分かりかねますが、とあるシートの特定列に、対応するキーワードがあるかどうかがチェックできればよいということであれば、連想配列を使わずとも解決可能だとおもいます。
【例】 ワークシート関数のMuchを使う Findメソッドを使う ←別件でxyzさんが案内済
■７
転記元ブック（設備*.xlsx）に該当シートがあるかどうかチェックする部分について、かなり複雑にしている印象があります。
シート名が（大文字、小文字を含め）固定されているならば下記で済む話だとおもいます。（件数を数えたいといった理由があるのかもしれませんが）
Sub 研究用03()
Dim bname As String
Dim wb1 As Workbook
Dim elm As Variant
Dim ws As Worksheet
Dim buf As String
bname = Dir(ThisWorkbook.Path & "\設備*.xlsx")
Application.Calculation = xlCalculationManual
Do While bname <> ""
buf = ""
Set wb1 = Workbooks.Open(ThisWorkbook.Path & "\" & bname)
For Each elm In Array("D6110", "D6120", "D6125", "D6560")
On Error Resume Next
Set ws = Nothing
Set ws = wb1.Worksheets(elm)
On Error GoTo 0
'該当するシートが無いとNothingのままになっているので、Nothingじゃないときだけ処理する
If Not ws Is Nothing Then
'〜〜〜wsの処理〜〜〜
End If
Next elm
bname = Dir()
Loop
End Sub
■８
ユーザー定義関数「read_1_sheet」について、「'月の取得 yyyy/mm からmmの数値を取得（0はエラー）」というコメントのとおり、
文字列操作をして【数値】を取り出しているわけですが、そこまでしなくてもいいんじゃないかなと思いました。
Sub 研究用04()
Dim 文字列 As Variant
Dim 月 As Long
For Each 文字列 In Array("", "2024/08", "2024/09", "2024/88", "2024/13", "2025/01")
月 = 研究用05(文字列)
If 月 = 0 Then
MsgBox "「" & 文字列 & "」は年月として認識できません"
Else
MsgBox "「" & 文字列 & "」から" & 月 & "月を取り出しました"
End If
Next 文字列
End Sub
'=======================================================================
Function 研究用05(文字列 As Variant) As Long
On Error Resume Next
研究用05 = Month(DateValue(文字列 & "/1"))
On Error GoTo 0
End Function
（もこな２） 2024/08/28(水) 07:37:37
■６
なるほど、dicTがコード内で提示されていないのですね
設備〜シートのF列が、連結修正後シートのE列にあるかを確認しているため、構想配列がなくても問題なさそうですね。
そちらを調べてみます。
■７
シート名は("D6110", "D6120", "D6125", "D6560")のみの予定ですので不要なようですね。
件数はもともと最後に出力？されるようなのですが、こちらが数えてないので合っているかわかっていない状況です。
チェックだけであれば不要・・・なるほど奥が深いです。
■８
掲示の「取得年月」「開始年月」が文字列で表記されているため、そこから取得→転記だと思っていたのですが
どうやら回り道をしているか、おおげさな動きをしているような感じでしょうか・・
いただいたコードを元に、どのような動きをするのか見てみたいと思います。
よい勉強になります、ありがとうございます。
（ヒロセ） 2024/08/28(水) 09:08:22
お返事いただいていたのに返信が遅くなり申し訳ありません。
VBAについて、便利な反面、わからない部分はこんなにも難しいのかと・・
勉強しておいた方が良いなと改めて思いました。
勉強後、自力で（これでなくても）何かしらのVBAを作成してみたいと思います。
つまづいたらまた、アドバイスお願いいたします。
（ヒロセ） 2024/08/28(水) 09:38:48
>勉強後、自力で（これでなくても）何かしらのVBAを作成してみたいと思います。 是非そのようにしてください。
VBscriptはWindowsから削除されてしまうので、現在ご呈示のコードは、正規表現を使用しているので、 将来使用できなくなる部分があります。
近い将来シート関数で正規表現を扱えるようになりますが(Microsoft 365 Insiderより入手可能)、現在のような使用はできなくなります。 又、現在のところ WorksheetFunction/Application にはリストされていませんのでEvaluateでの使用に限られます。
上記を考慮して、再考してください。 （jindon） 2024/08/28(水) 11:09:39
初心者にはまったく何がなんだか、状態ですが、とにかく提示したコードでは動かなくなってしまうということですね。
しかも部分的に動かなくなる可能性があると。
ありがとうございます、ぜひ勉強して再考したいと思います。
（ヒロセ） 2024/08/28(水) 12:31:14
補足しておきます。
モジュールレベルで宣言した変数
>Dim RE As Object '正規表現オブジェクト
この宣言事態は問題ありませんが、
>Public Sub 月度対応転記()
の中の
> Set RE = CreateObject("VBScript.RegExp")
この時点でコンパイルエラーになるので、コードは終了してしまいます。
>Private Function get_month(ByVal wmonth) As Long での > If RE.test(wmonth) = False Then Exit Function も勿論変更必須行です。
いかに他所に変更・修正を加えても、これを解決しないと無駄になるということです。 （jindon ） 2024/08/28(水) 16:42:24
jindonさんのコメントはそのとおりですね。
[[20240527121912]]でも書きましたが、Microsoftもそのこと(VBAでの正規表現ライブラリーの利用）は認識していて、
.vbsファイルが動かなくなるのと同時に、ライブラリ参照も廃止とすることはないとしています。
既存資産がありますので、ある程度慎重に事を進めるものと想像しています。
なお、今回のRE.Pattern = "^\d{4}/\d{2}$"でしたら、簡単にLikeで代替できるので問題にはならないでしょうけど。
【余談】ワークシートの正規表現に使用される正規表現エンジンはPCRE2だそうですね。(その後どこかの記事で見かけました） 一般的なPerl Compatibleなものなので安心しました。 （xyz） 2024/08/28(水) 17:02:54
xyzさん 私自身も正規表現を多用してきましたので、修正に苦労しています。 今回のような簡単なマッチングならご指摘のLike演算子の方が簡単だし早いと思います。 （jindon ） 2024/08/28(水) 17:22:22
■９
＞管理シートのE2セルには、今月（もしくは来月）を手入力しております
そういった話ならば、【入力規則】で1〜12の整数以外を受け付けないようにして置いたら如何でしょうか？
そしたら、空白だったらエラー、そうじゃなければ取得と単純化できませんか？
■10
＞国内_連結修正後のみを指定されていますが、国内_計上連結修正後と比べている？のでしょうか？
もういちど、【ステップ実行】をしながらどこで何をしているのか確認されては如何でしょうか？
'転記先ブックのシートチェック
Private Function check_out_sheet(wb2 As Workbook) As Boolean
Dim maxrow1 As Long, wrow As Long
Dim エラーメッセージ As String
With wb2.Worksheets("国内_連結修正後")
maxrow1 = .Cells(.Rows.Count, "J").End(xlUp).Row
Select Case True
Case maxrow1 < 14
エラーメッセージ = "転記先ブックの２つのシートの行数が正しくありません"
Case (maxrow1 - 10) Mod 4 <> 0
エラーメッセージ = "転記先ブックの２つのシートの行数が正しくありません"
Case maxrow1 <> wb2.Worksheets("国内_計上連結修正後").Cells(.Rows.Count, "J").End(xlUp).Row
エラーメッセージ = "転記先ブックの２つのシートの行数が不一致です"
Case Else
For wrow = 7 To maxrow1 - 4 Step 4
'▼注目するべき行
If .Cells(wrow, "E").Value <> wb2.Worksheets("国内_計上連結修正後").Cells(wrow, "E").Value Then
エラーメッセージ = "転記先ブックの２つのシートの装置名の並びが不一致です"
Exit For
End If
Next wrow
End Select
End With
If エラーメッセージ = "" Then
check_out_sheet = True
Else
MsgBox エラーメッセージ
check_out_sheet = False
End If
End Function
■11
＞なるほど、dicTがコード内で提示されていないのですね
xyzさんの↓のコメントはどのように理解されてますか？ ＞ (必ずしも連続はしていないということなら、dictinaryを使った別の仕組みが必要になるでしょう。 ＞ なお、dicTの登録処理もどこで実行しているのか不明で、読んでいて気になりました。）
なお、「構想配列」じゃなくて「連想配列」です。 ↓あたりを読んでみるのもよいかもしれません。 http://www.officetanaka.net/excel/vba/tips/tips52.htm
＞設備〜シートのF列が、連結修正後シートのE列にあるかを確認している
たとえば、ワークシートで↓のような関数を使えば、発見された場合は何番目にあるか表示されますし、 見つからない場合はエラーになりますよね？ =MATCH(設備!F1,国内_連結修正後!F:F,0)
また、手作業で有無を調べようとしたら↓のようにしませんか？、 1. 連結修正後シートのE列全体を選択する 2. 「検索と置換」ダイアログを開く 3. 「検索する文字列」に検索したいキーワードを入れる 4. 「すべて検索」or「次を検索」を押す
前者が【ワークシート関数のMatchを使う方法】、 後者が【Findメソッドを使う方法】です。
（もこな２） 2024/08/30(金) 07:52:39
[4桁の数字]/[2桁の数字]
そうなると、「8888/88」みたいな物もパターンチェックでは、ok判定になってしまう気がします。
よって、こちらも「年/月」の形式以外はあり得ないなら、■６・■７・■９のような単純化ができるのではないかとおもいました。
（もこな２） 2024/08/30(金) 09:09:22
まだ正規表現がどうとかわかっていないのですが、ご提示いただいた
Set RE = CreateObject("VBScript.RegExp")
If RE.test(wmonth) = False Then Exit Function
こちらはLike演算子で代替できるとのこと、演算子の方から調べてみようと思います。
もこな２さん
■９
入力規制についてはなんとなーく知っていますので、そちらをまず設定してみようかと思っています。
それであれば管理シートE2セルに関するコードが簡潔になる・・んですかね。
だと見やすくなりますし、理解もしやすくなるのでしょうが・・・
■10
ステップ実行！
そうですね、動き方を見てみます。ありがとうございます。
■11
そもそもdicTのコードがどこにあるかもわかっていないのですが、
どこかの辞書的？なものに登録されたものを参照し、なければエラー。と認識しています。
全然違っていたら申し訳ないです。
＞前者が【ワークシート関数のMatchを使う方法】、 ＞後者が【Findメソッドを使う方法】
こちらも詳しく知っていきたいですね。
マクロの記録でコードの理解を深めていきたいです。
もこな２さんにいただいたコードを流用してマクロを走らせてみたのですが、まず管理シートの一行目でつまづいてしまい、どれも転記されませんでした。
どこがどう変わったのかを確認していたのですが、こちらもステップ実行でなんとかなりそうです。
（なんともならなかったらまた質問させてくださいますと幸いです。）
（ヒロセ） 2024/08/30(金) 10:45:54
(気づいた点等がなければこれで最後にします。)
■12
＞シート名は("D6110", "D6120", "D6125", "D6560")のみの予定ですので不要なようですね。
こちらとしては↓のようなことを言っているのですが伝わってますか？
Sub 研究用06()
Dim ws As Worksheet
Dim i As Long
Dim elm As Variant
With Workbooks.Add
For i = 1 To 5
Worksheets.Add after:=.Worksheets(.Worksheets.Count)
Next
.Worksheets(1).Name = "D6120"
.Worksheets(3).Name = "hoge"
.Worksheets(5).Name = "ほげ"
.Worksheets(6).Name = "d6110"
On Error Resume Next
For Each elm In Array("D6110", "D6120", "D6125", "D6560")
Set ws = Nothing
Set ws = .Worksheets(elm)
If Not ws Is Nothing Then
'▼該当するシートがあるときだけ実行される
MsgBox ws.Name & "シートの処理を実行！"
End If
Next
On Error Goto 0
For Each elm In Array("D6110", "D6120", "D61
End With
End Sub
■13
＞管理シートE2セルに関するコードが簡潔になる・・んですかね。
Sub 研究用07()
Dim out_mm As Long
If IsNumeric(ThisWorkbook.Worksheets("管理").Range("E2").Value) = True Then
out_mm = CLng(ThisWorkbook.Worksheets("管理").Range("E2").Value)
End If
If out_mm < 1 Or out_mm > 12 Then
MsgBox ("管理シートの出力月が不正です")
Exit Sub
Else
MsgBox out_mm & "月が設定されています"
End If
End Sub
↑について【""あるいは1〜12の整数】に限定できるなら↓で済むんじゃないか？と言ってるのですが伝わってますか？
Sub 研究用08()
Dim out_mm As Long
out_mm = ThisWorkbook.Worksheets("管理").Range("E2").Value
If out_mm = 0 Then
MsgBox ("管理シートの出力月が入力されていません")
Exit Sub
Else
MsgBox out_mm & "月が設定されています"
End If
End Sub
■14
＞どこかの辞書的？なものに登録されたものを参照し、なければエラー。
概ねその認識であってます。（エラーではなく有無を判定しているのですが） なので、辞書に登録する部分が提示されてないですよと指摘されています。
＞設備〜シートのF列が、連結修正後シートのE列にあるかを確認している
前述のとおり、どこを探しているのかはわかりかねますが、↓を見る限り 【B列】か【A列】をいじっているように見えるのですが････
'装置名チェック
sname = ws.Cells(wrow, "B").Value
If dicT.exists(sname) = False Then
sname = get_sname(ws.Cells(wrow, "A").Value) '★ココ
End If
'転記先の装置名が存在する場合
If sname <> "" Then
tk_row = dicT(sname)
t_col = get_column(t_mm)
k_col = get_column(k_mm)
ows1.Cells(tk_row, t_col).Value = ws.Cells(wrow, "E").Value '投資用金額
ows2.Cells(tk_row, k_col).Value = ws.Cells(wrow, "E").Value '計上用金額
data_count = data_count + 1
End If
Private Function get_sname(ByVal kbango As String)
Dim ptn As String
Dim wrow As Long
For wrow = 2 To k_maxrow1
ptn = ks1.Cells(wrow, "A").Value
If kbango Like ptn Then
get_sname = ks1.Cells(wrow, "B").Value'★ココ
ks2.Cells(k_maxrow2, "A").Value = kbango
ks2.Cells(k_maxrow2, "B").Value = ptn
ks2.Cells(k_maxrow2, "C").Value = ks1.Cells(wrow, "B").Value
k_maxrow2 = k_maxrow2 + 1
Exit Function
End If
Next
get_sname = ""
End Function
■15
'月数からカラム番号を取得する
Private Function get_column(ByVal mm As Long) As Long
Dim bias As Long: bias = 8
If mm < 4 Then mm = mm + 12
If mm > 9 Then bias = bias + 1
get_column = mm + bias
End Function
↑は↓ということですかね。
Private Function get_column(ByVal mm As Long) As Long
Select Case mm
Case 1 To 3
get_column = mm + 12 + 8
Case 4 To 8
get_column = mm + 9
Case 9 To 12 '９月以降
get_column = mm + 8
End Select
End Function
■16
というようなことを踏まえて、最初のコードを（憶測込みで）私なりに整理してみると↓のようになります。
Public Sub 月度対応転記()
Dim out_mm As Long '出力月数
Dim ws As Worksheet
Dim buf As Variant
Dim wb1 As Workbook '転記元ブック
Dim wb2 As Workbook '転記先ブック
Dim maxrow1 As Long, wrow As Long
Dim エラーメッセージ As String
Dim elm As Variant
Dim MyDate As Date
Dim 〇〇 As Range
Dim bname As String
Dim t_col As Long, k_col As Long
'▼出力月のチェック（取得）
With ThisWorkbook.Worksheets("管理").Range("E2")
If .Value = "" Then
MsgBox "管理シートのE2セルが空白のままです" & vbLf & "入力してから実行してください"
Else
out_mm = .Value
End If
End With
'▼'転記先ブックオープン
Set wb2 = Workbooks.Open(ThisWorkbook.Path & "\帳票.xlsx")
'▼'転記先ブックのシートチェック
With wb2.Worksheets("国内_連結修正後")
maxrow1 = .Cells(.Rows.Count, "J").End(xlUp).Row
Select Case True
Case maxrow1 < 14
エラーメッセージ = "転記先ブックの２つのシートの行数が正しくありません"
Case (maxrow1 - 10) Mod 4 <> 0
エラーメッセージ = "転記先ブックの２つのシートの行数が正しくありません"
Case maxrow1 <> wb2.Worksheets("国内_計上連結修正後").Cells(.Rows.Count, "J").End(xlUp).Row
エラーメッセージ = "転記先ブックの２つのシートの行数が不一致です"
Case Else
For wrow = 7 To maxrow1 - 4 Step 4
If .Cells(wrow, "E").Value <> wb2.Worksheets("国内_計上連結修正後").Cells(wrow, "E").Value Then
エラーメッセージ = "転記先ブックの２つのシートの装置名の並びが不一致です"
Exit For
End If
Next wrow
End Select
End With
If エラーメッセージ <> "" Then
MsgBox エラーメッセージ & vbLf & wb2.Name & "ブックの「国内_連結修正後」と「国内_計上連結修正後」の両シートを再確認してください"
Exit Sub
End If
'転記元の全シートを処理する
Application.Calculation = xlCalculationManual
bname = Dir(ThisWorkbook.Path & "\設備*.xlsx")
Do While bname <> ""
Set wb1 = Workbooks.Open(ThisWorkbook.Path & "\" & bname)
For Each elm In Array("D6110", "D6120", "D6125", "D6560")
On Error Resume Next
Set ws = Nothing
Set ws = wb1.Worksheets(elm)
If Not ws Is Nothing Then
For wrow = 2 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'投資月チェック
On Error Resume Next
MyDate = 0
MyDate = DateValue(ws.Cells(wrow, "C").Value & "/1")
On Error GoTo 0
If MyDate = 0 Then
MsgBox "「" & ws.Cells(wrow, "C").Value & "」を年/月とみなせませんでした" & vbLf & "確認のうえ再実行してください。"
Application.Goto ws.Cells(wrow, "C")
Exit Sub
End If
'計上月チェック
On Error Resume Next
MyDate = 0
MyDate = DateValue(ws.Cells(wrow, "D").Value & "/1")
On Error GoTo 0
If MyDate = 0 Then
MsgBox "「" & ws.Cells(wrow, "D").Value & "」を年/月とみなせませんでした" & vbLf & "確認のうえ再実行してください。"
Application.Goto ws.Cells(wrow, "D")
Exit Sub
End If
'装置名チェック
'〜〜Findメソッドで、？？？の値をキーに？？？があるか探す〜〜
If Not 〇〇 Is Nothing Then '見つかったら処理
t_col = get_column(Month(DateValue(ws.Cells(wrow, "C").Value & "/1")))
k_col = get_column(Month(DateValue(ws.Cells(wrow, "D").Value & "/1")))
'投資用金額(〇〇の行・月から該当列を特定して書き込む)
With wb2.Worksheets("国内_連結修正後").Cells(〇〇.Row, t_col)
.Value = ws.Cells(wrow, "E").Value
End With
'計上用金額(〇〇の行・月から該当列を特定して書き込む)
With wb2.Worksheets("国内_計上連結修正後").Cells(〇〇.Row, k_col)
.Value = ws.Cells(wrow, "E").Value
End With
End If
Next wrow
End If
Next elm
wb1.Close
bname = Dir()
Loop
End Sub
'=================================================================
Private Function get_column(ByVal mm As Long) As Long
Select Case mm
Case 1 To 3
get_column = mm + 12 + 8
Case 4 To 8
get_column = mm + 9
Case 9 To 12
get_column = mm + 8
End Select
End Function
■17
上記のように整理してみると、値を書き込んでいるのは↓の部分ということがわかりますから
'投資用金額(〇〇の行・月から該当列を特定して書き込む)
With wb2.Worksheets("国内_連結修正後").Cells(〇〇.Row, t_col)
.Value = ws.Cells(wrow, "E").Value
End With
'計上用金額(〇〇の行・月から該当列を特定して書き込む)
With wb2.Worksheets("国内_計上連結修正後").Cells(〇〇.Row, k_col)
.Value = ws.Cells(wrow, "E").Value
End With
もとあった数字に加算するようにしたいのであれば↓のようにすればよいことがわかるのではないでしょうか？
With wb2.Worksheets("国内_連結修正後").Cells(〇〇.Row, t_col)
.Value = .Value + ws.Cells(wrow, "E").Value
End With
'計上用金額(〇〇の行・月から該当列を特定して書き込む)
With wb2.Worksheets("国内_計上連結修正後").Cells(〇〇.Row, k_col)
.Value = .Value + ws.Cells(wrow, "E").Value
End With
（もこな２） 2024/09/03(火) 06:56:54
一旦こちらは予測値の０クリア、加算が出来たので、その手前の部分（ガッと削除をマクロの記録でやってみては？）を試していたところです。
あちらの回答も参考になりました。ありがとうございます。
■12
設備xlsx内のシート名を検索して、("D6110", "D6120", "D6125", "D6560")があったときは処理実行、でしょうか？
この、Nextの後の.Worksheets(1).Name =ですが、これは"hoge"や"ほげ"というシートは実行されない？（シート名を検索している？）
■13
＞管理シートE2セルに関するコードが簡潔になる・・んですかね。
Sub 研究用07()
Dim out_mm As Long
If IsNumeric(ThisWorkbook.Worksheets("管理").Range("E2").Value) = True Then
out_mm = CLng(ThisWorkbook.Worksheets("管理").Range("E2").Value)
End If
If out_mm < 1 Or out_mm > 12 Then
MsgBox ("管理シートの出力月が不正です")
Exit Sub
Else
MsgBox out_mm & "月が設定されています"
End If
End Sub
↑について【""あるいは1〜12の整数】に限定できるなら↓で済むんじゃないか？と言ってるのですが伝わってますか？
Sub 研究用08()
Dim out_mm As Long
out_mm = ThisWorkbook.Worksheets("管理").Range("E2").Value
If out_mm = 0 Then
MsgBox ("管理シートの出力月が入力されていません")
Exit Sub
Else
MsgBox out_mm & "月が設定されています"
End If
End Sub
■14
A列かB列・・・ですか
登録する部分であり、A列かB列に該当するのは、ガッと削除したあとのエクセルファイルですかね
それかマクロ入りエクセルの管理シートでしょうか・・
ただ、今のコードを読んでいただいた限りですとそこが指定されていないと
指定はされていないけれど、A列かB列をいじってはいる、と
■15
そもそもbiasがなにを指しているのかまだわかっていないのですが
もこな２さんのですと、１月から３月の場合、４月から８月の場合、９月以降で区切られているんですね
このcaseを使用して多岐条件分岐をさせるコード、使おうとして勉強してました。
■16
さっそくいただいたマクロを走らせてみました。
まず転記先ブックでつまづいているのでご教示いただきたく・・
Set wb2 = Workbooks.Open(ThisWorkbook.Path & "\帳票.xlsx")
ですが、帳票.xlsxのフォルダ名とファイル名が同じでないと開けないので
エラーが出て止まってしまいました。
■17
〇〇の部分には何が入るのでしょう？
Dim 〇〇 As Range ここで変数？を指定するのはわかったのですが・・・
質問ばかりで申し訳ないです。
お時間のある時にご教示ください。
（ヒロセ） 2024/09/03(火) 09:08:04
■18
＞設備xlsx内のシート名を検索して、("D6110", "D6120", "D6125", "D6560")があったときは処理実行、でしょうか？
ステップ実行で【どのような挙動になるか】確認してください。
■19
＞A列かB列・・・ですか
既に述べたように、ユーザー定義関数が多用されて読みづらいので見間違えているかもしれませんが ↓で出てきているのはB列なり、A列ではないですか？
sname = ws.Cells(wrow, "B").Value ^^^ If dicT.exists(sname) = False Then
sname = get_sname(ws.Cells(wrow, "A").Value)
^^^
get_sname = ks1.Cells(wrow, "B").Value
^^^
■20
＞そもそもbiasがなにを指しているのかまだわかっていないのですが
↓を読み直されては如何でしょうか？
'月数からカラム番号を取得する
Private Function get_column(ByVal mm As Long) As Long
Dim bias As Long: bias = 8 '★ココ
If mm < 4 Then mm = mm + 12
If mm > 9 Then bias = bias + 1
get_column = mm + bias
End Function
■21
＞さっそくいただいたマクロを走らせてみました。
誤解させてしまったらごめんなさいですが、完成品プレゼントの意図はありません。 あくまで説明用として、私なりに"整理"したものとして提示しました。
＞ですが、帳票.xlsxのフォルダ名とファイル名が同じでないと開けない
そこは変えてないハズです。
Const Book2 As String = "帳票" Folder2 = ThisWorkbook.Path bname2 = Book2 & ".xlsx" bpath2 = Folder2 & "\" & bname2 Set wb2 = Workbooks.Open(bpath2)
↑を↓に整理しただけです。
Set wb2 = Workbooks.Open(ThisWorkbook.Path & "\帳票.xlsx")
■22
＞〇〇の部分には何が入るのでしょう？
お好きな（ご自身がわかりやすい）ものでどうぞ。 何なら「○○」でも動作するはずです。
（もこな２） 2024/09/04(水) 12:59:19
回答ありがとうございます。
ステップ実行してみて、わからなければまた質問しに来ます。
まずはもこな２さんからいただいたデータを読み解くこと（ステップ実行）から始めようかと。
初心者の私にもわかるよう、だいぶ簡潔にしていただきましたので。
Set wb2 = Workbooks.Open(ThisWorkbook.Path & "\帳票.xlsx") が、なぜかエラーになりますが、そこも含めて検証したいと思います。
わざわざありがとうございました。
（ヒロセ） 2024/09/05(木) 09:05:21
Sub 研究用06()
〜〜〜中略〜〜〜
On Error Goto 0
For Each elm In Array("D6110", "D6120", "D61 ←この行要らないです
End With
End Sub
Public Sub 月度対応転記()
〜〜〜中略〜〜〜
Dim buf As Variant ←この行要らないです
■24
＞ Set wb2 = Workbooks.Open(ThisWorkbook.Path & "\帳票.xlsx")
＞が、なぜかエラーになりますが、そこも含めて検証したいと思います。
一度、イミディエイトに以下のように入力してみて、ちゃんとフルパスになるか確認してみてはどうでしょうか？
（たとえば、新規ブックで試していてThisWorkbook.Pathが""になっていたとかいうオチはないですか？）
?ThisWorkbook.Path & "\帳票.xlsx"
あとは、自ブックがonedriveに同期されていて「ThisWorkbook.Path」がローカルをじゃないほうになってしまっているとか・・・・
■25
特に確認がなかったので提示していませんでしたが、【ステップ実行】【イミディエイト（ウィンドウ）】などがよくわからないという場合は↓あたりを読んでみると理解が進むかもしれません。
【ステップ実行】 https://www.239-programing.com/excel-vba/basic/basic023.html http://plus1excel.web.fc2.com/learning/l301/t405.html
【ブレークポイント】 https://www.239-programing.com/excel-vba/basic/basic022.html https://www.tipsfound.com/vba/01010
【イミディエイトウィンドウ】 https://www.239-programing.com/excel-vba/basic/basic024.html https://excel-ubara.com/excelvba1/EXCELVBA486.html
【ローカルウィンドウ】 https://excel-ubara.com/excelvba4/EXCEL266.html http://excelvba.pc-users.net/fol8/8_2.html
【変数の宣言を強制する】 http://officetanaka.net/excel/vba/beginner/06.htm#google_vignette https://www.javadrive.jp/excelvba/basic/index9.html#google_vignette
（もこな２） 2024/09/05(木) 12:18:44
?ThisWorkbook.Path & "\帳票.xlsx"
ここですが、フォルダパスはあっているようです。
が、帳票が「帳票」という名前でないことがエラーの原因かと。
〜〜〜帳票.xlsx
なのですが、＊をつければよいのかと思って調べてみたもののそうではないようで・・・
この辺りを調べつつ、検証していけたらと思います。
開かなければ先に進みませんし・・
（ヒロセ） 2024/09/05(木) 13:06:59
その考えで合っています。 エラーというより当然の結果でしょう。（そのようなパスのファイルが無いのですから）
＞＊をつければよいのかと思って調べてみたもののそうではないようで・・・
そのとおりです。 Openメソッドで使用するブック名（パス）に、*(ワイルドカード）は使用できません。
ワイルドカードを使うならば↓と同じように、一旦、該当するブック名を調べる（取得する）必要があります bname = Dir(ThisWorkbook.Path & "\設備*.xlsx") Set wb1 = Workbooks.Open(ThisWorkbook.Path & "\" & bname)
もちろん、該当するものが複数ある場合は、ヒットしたものが目的のものかどうか判定する仕組みが必要になります。
例えば↓から日付っぽいものを取り出して最新のものであろうファイルを開くという話ならば
設備0831.xls
設備0901.xls
設備0905.xls
ループ処理開始
(1)日付っぽい部分を取り出して、日付に変換する
(2)覚えていた日付と比較してより新しい方を覚えなおす
ループ処理終了
(3)"設備" と 覚えた日付 と ".xlsx" を組み立てて【ブック名】にする (4)【フォルダパス】と【ブック名】を組み合わせて、ブックを開く
のような動作を考える必要があります。
（もこな２） 2024/09/05(木) 13:47:56
詳しいご説明ありがとうございます。
なるほど、ということはブック名をフルパスで指定するか、
ブック名を調べて開く、がパターンとしてあるわけですね。
簡単なのはフルパス指定だと思うのですが、それだと似た名前（かっこが全角半角、スペースの有無）であったり、または名前を変えてしまった場合にエラーになる。
という認識で間違いないでしょうか？
複数だともっと複雑に指定しないといけないわけですね。
参考になります。
今回はブック名が変わる心配がないので、フルパス指定にしようかと思っています。
ブックの名前があることで、見た目にもわかりやすいなと感じました。
（ヒロセ） 2024/09/05(木) 13:54:47
一度、Openメソッドについて調べてみることを強くお勧めします。
そのうえで一応説明しますが、フルパスでなくブック名のみで指定することは可能です。 ただし、フォルダを省略した場合、カレントディレクトリを指定したとみなされます。
＞それだと似た名前（かっこが全角半角、スペースの有無）であったり、
＞または名前を変えてしまった場合にエラーになる。
上記と被りますが、似てるかどうかは関係ありません。 そのものズバリのものがあるかどうかです。 １文字でも違えば別物です。
逆を言えば、同名のファイルがカレントディレクトリにあれば、 それを開いてしまいますので、個人的にはフルパスでの指定をお勧めします。
■28
＞複数だともっと複雑に指定しないといけないわけですね。
難しいことを言ったつもりはありませんので落ち着いて考えてみてください。
なお、別のアプローチとして【ダイアログボックスを出してユーザーに指定してもらう】 みたいなことでもよいと思います。 それなら、カレントフォルダやら複数あった場合の特定などは考えなくてもよいです。 （ユーザーがやってくれますので）
（もこな２） 2024/09/05(木) 17:30:47
openメソッドですね。
ありがとうございます、理解できるまで調べてみます。
認識が違ったようで申し訳ないです。
まったく同一でないとブックが開かない。なるほどです。
やはりフルパス指定が間違いなさそうですね
ダイアログボックスですか！
そういう観点もありでしたね。
openメソッド、ダイアログボックスも視野に入れて作ってみます。
（ヒロセ） 2024/09/06(金) 09:10:51
openメソッドについて、フルパス指定しようとしたのですが
勉強のためにこちらで練習しております
bname = Dir(ThisWorkbook.Path & "\*帳票.xlsx")
これをもとに理解を深めているつもりです。
たくさんのアドバイスありがとうございました！
（ヒロセ） 2024/09/10(火) 08:35:14
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.