[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『マクロで二つの元ブックから様式ブックへの転記』（usamiyu）
いつも大変お世話になっております。長文失礼します。また、ご相談させてください。
様式ブック並びに転記元ブックm及び転記元ブックgが同一フォルダにあります。 これらとは別にマクロを記載したブックを作り、以下の手順で転記したいと考えました。 書いたコードは下記のとおりですが、For each構文でループするつもりが、情けないことに同じ箇所に 上書きされてしまいます。 どなたかどうかお知恵をお貸しいただけないでしょうか。
【手順】 １ 様式ブックを開く ２ 転記元ブックm（csvファイル）を開く ３ 転記元ブックg（csvファイル）を開く ４ サブルーチンで集計機能を使い、mを加工、gを加工 ５ 様式ブックのC、F列の該当行に値(前月）が入っていたら、D、G列の値（当期）を上書きする ６ D、G列の該当行をクリアする ７ 転記元ブックmのシートshfrommの各行のOutlineLevelが２だったら、様式ブックのD12〜D16の各セルに、 shfrommの各行のAB列の値を代入する （←ココがD12に上書きされて失敗中です。） ８ 同じく、様式ブックのG12〜G16の各セルに、shfrommの各行のAE列の値を代入する ９ ７，８と同じことを転記元ブックgの条件で行う １０ 転記元ブックmをxl形式で保存して閉じる １１ 転記元ブックgをxl形式で保存して閉じる １２ 様式ブックを同じフォルダにA1セルの名前で保存、印刷して閉じる
【レイアウト】
(様式ブック)
[A] [B] [C] [D] [E] [F] [G] [H]
[1] 平成25年度 報告書（ 4月末現在）
[2]
[3] （単位： 円）
[4]
[5] 項目 種別 仮 支出
[6] 前月 当期 計 前月 当期 計
〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜中略〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜
[12] M j 0 0
[13] ｔ 200 200 0
[14] i 100 300 400 0
[15] k 0 0
[16] ｇ 100 100 0
[17] M計 100 600 700 0 0 0
[18] G j 0 0
[19] ｔ 400 400 0
[20] i 80 50 130 0
[21] k 0 0
[22] G計 80 450 530 0 0 0
(転記元ブックm)※上記手順４にて加工後の姿（転記元ブックｇも同様のレイアウト）
[S] [T] [U] [V] [W] [X] 〜〜 略 〜〜 [Z] [AA] [AB] [AC] [AD] [AE] [AF]
[1] 種別 取引年 月 取引日 番号 摘要 YY KK SS ** ※ FF TT
[2] ｔ 5 1 ○○ 0 100 0 0 0 0 0
[3] ｔ 5 1 ○○ 0 0 100 0 0 0 0
[4] ｔ 5 1 ○○ 0 0 0 0 0 100 5
[5] ｔ 集計 100 100
[6] i 5 3 △△ 0 200 0 0 0 0 0
[7] i 5 3 △△ 0 0 200 0 0 0 0
[8] i 5 3 △△ 0 -10 -10 0 0 0 0
[9] i 集計 190 0
[10] k 5 8 ×× 0 300 0 0 0 0 0
[11] k 5 8 ×× 0 0 300 0 0 0 0
[12] k 5 8 ×× 0 0 0 0 0 300 15
[13] k 集計 300 300
[14] g 5 15 ◎◎ 0 400 0 0 0 0 0
[15] g 5 15 ◎◎ 0 0 400 0 0 0 0
[16] g 5 15 ◎◎ 0 -20 -20 0 0 0 0
[17] g 集計 380 0
[18] 総計 970 400
【コード】
（長くなるので、サブルーチンShikkouseiriListは割愛しています。）
Sub Make_Report()
Dim wbt As Workbook '様式ブック
Dim wbm As Workbook '転記元ブックm
Dim wbg As Workbook '転記元ブックｇ
Dim shfromm As Worksheet
Dim shfromg As Worksheet
Dim shtod As Worksheet '転記先シート
Dim Filepathm As Variant
Dim Filepathg As Variant
Dim FilePatht As Variant
Dim r As Range '様式ブックの前月欄の範囲
Dim c As Range
Dim rm1 As Range '様式ブックの項目Mの「仮」の当期の範囲
Dim rm2 As Range '様式ブックの項目Mの「支出」の当期の範囲
Dim cm1 As Range
Dim cm2 As Range
Dim rg1 As Range '様式ブックの項目Gの「仮」の当期の範囲
Dim rg2 As Range '様式ブックの項目Gの「支出」の当期の範囲
Dim cg1 As Range
Dim cg2 As Range
Dim myRow As Range
Dim sep As String
sep = Application.PathSeparator '\
'調査票様式を選択
FilePatht = Application.GetOpenFilename("Excelファイル,*.xls*", , "様式ファイルを開く")
If FilePatht = False Then Exit Sub
'調査票様式ファイルを開く
Set wbt = Workbooks.Open(FilePatht)
Set shtod = wbt.Sheets(1)
'転記元ブックm選択
Filepathm = Application.GetOpenFilename("csvファイル,*.csv", , "ｍを開く")
If Filepathm = False Then Exit Sub
'転記元ブックmを開く
Set wbm = Workbooks.Open(Filepathm)
Set shfromm = wbm.Sheets(1)
'転記元ブックg選択
Filepathg = Application.GetOpenFilename("csvファイル,*.csv", , "ｇを開く")
If Filepathg = False Then Exit Sub
'転記元ブックgを開く
Set wbg = Workbooks.Open(Filepathg)
Set shfromg = wbg.Sheets(1)
Application.ScreenUpdating = False '画面描画停止
MsgBox "題名に今月を入力しましたか？" 'vbOKonlyにしておいて、忘れていたら入力する?Exitはしたくない
'--------------------------------------------------------
'転記元csvファイルを加工したものを子プロシージャから呼ぶ
'--------------------------------------------------------
Call ShikkouseiriList(shfromm)
Call ShikkouseiriList(shfromg)
'--------------------------------------------------------
'様式ブック（転記先シート）への転記処理
'--------------------------------------------------------
With shtod
Set r = .Range("C12:C16,C18:C21,F12:F16,F18:F21") '前月欄
For Each c In r
If Len(c.Value) >= 1 Then c.Value = c.Offset(, 1).Value '前月欄が記載してあれば、当期欄の値を前月欄に移す
Next
r.Offset(, 1).ClearContents '当期欄をクリア
Set rm1 = .Range("D12:D16") '項目Mの「仮」の当期欄
Set rm2 = .Range("G12:G16") '項目Mの「支出」の当期欄
For Each cm1 In rm1
For Each myRow In shfromm.Range("A1").CurrentRegion.Rows
If myRow.OutlineLevel = 2 Then
cm1.Value = myRow.EntireRow.Range("AB1").Value '＜-------ここでcm1がループせず上書になってしまう。
End If
Next
Next
For Each cm2 In rm2
For Each myRow In shfromm.Range("A1").CurrentRegion.Rows
If myRow.OutlineLevel = 2 Then
cm2.Value = myRow.EntireRow.Range("AE1").Value
End If
Next
Next
Set rg1 = .Range("D18:D21") '項目Gの「仮」の当期欄
Set rg2 = .Range("G18:G21") '項目Gの「支出」の当期欄
For Each cg1 In rg1
For Each myRow In shfromg.Range("A1").CurrentRegion.Rows
If myRow.OutlineLevel = 2 Then
cg1.Value = myRow.EntireRow.Range("AB1").Value
End If
Next
Next
For Each cg2 In rg2
For Each myRow In shfromg.Range("A1").CurrentRegion.Rows
If myRow.OutlineLevel = 2 Then
cg2.Value = myRow.EntireRow.Range("AE1").Value
End If
Next
Next
End With
MsgBox "転記終了"
'-------------------------------------------------------- '転記元、転記先ブックを保存する '--------------------------------------------------------
'転記元ブックm保存
wbm.SaveAs Filepathm & sep & Left(shfromm.Range("A2"), 6) & shfromm.Range("Q2") & ".xls", FileFormat:=xlNormal
wbm.Close False
'転記元ブックg保存
wbg.SaveAs Filepathg & sep & Left(shfromg.Range("A2"), 6) & shfromg.Range("Q2") & ".xls", FileFormat:=xlNormal
wbg.Close False
Application.ScreenUpdating = True '画面描画再開
'様式ブックを同じフォルダにA1セルの名前で保存
With wbt
.SaveAs FilePatht & sep & Sheets(1).Range("A1") & ".xls"
.Sheets(1).PrintPreview
.Sheets(1).PrintOut
.Close
End With
End Sub
やりたかったことは、rm1内の各セル に、shfrommの行の中のOutlineLevelが2のものの AB列の値を 順番に書き込みたいということかな？ 同じような構造のところが他にもあって、そこはうまくいっているということであれば、ちょっと悩んでしまうんだけど？
確かに【長文】なので、usamiyuさんも回答者さん達も、なんだかわかりにくくなってしまいがちだけど、もし、やりたかったことが このとおりなら、コードとしては
For Each cm1 In rm1
For Each myRow In shfromm.Range("A1").CurrentRegion.Rows
If myRow.OutlineLevel = 2 Then
cm1.Value = myRow.EntireRow.Range("AB1").Value '＜-------ここでcm1がループせず上書になってしまう。
End If
Next
Next
この制御構造のところだけなので、ここだけをサンプルコードとして作って、短いＶＢＡで検証・デバッグしたほうが 効率がよくなる場合がある。あるいは、ここだけを【じっと見つめる】とか。
新規ブックで、B1;B5に任意の値をいれて以下を実行して、結果の違いをみたうえで、両方のコードをじっと見比べてみて。
Sub TestNG()
Dim f As Range
Dim t As Range
For Each t In Range("A1:A5")
For Each f In Range("B1:B5")
t.Value = f.Value
Next
Next
End Sub
Sub TestOK()
Dim f As Range
Dim t As Range
Set t = Range("A1")
For Each f In Range("B1:B5")
t.Value = f.Value
Set t = t.Offset(1)
Next
End Sub
(ぶらっと)
ぶらっとさん いつもありがとうございます!
>やりたかったことは、rm1内の各セル に、shfrommの行の中のOutlineLevelが2のものの AB列の値を 順番に書き込みたいということかな？ まさしく、そのとおりです！ こんなに長文だと読むだけでみなさま、いやになっちゃうだろうなぁと思いながらも・・すみません！！のSOSでした。 それなのにちゃんと読み取って、回答していただけて、大感謝しています。
Test試してみました。私がネストしているつもりだったNGバージョンは、やっぱり上書きされてしまうんですね。 OKバージョンだと動くことを確認しました。これは、For Next構文のときに使う、転記先行＝転記先行+1 みたいな感じですね。 実はFor Nextでも考えていたのですが、試行錯誤してもできず、挫折していました。
それで、以下のように記述してみたのですが、ステップ実行で１行ずつだと上手く転記されて、MsgBox "転記終了"まで行くのに、いざ実行 してみると、どこにも転記されません？？ ・・・どーなっちゃったんでしょう？・・自分でももう少し考えます・・・が、もし、よろしかったら、間違っている点を教えていただけますか？ 甘えてばかりで申し訳ありませんm(__)m
Set cm1 = Range("D13") '項目Mの「仮」の当期欄 ※種別jのデータが今存在しないのでD13種別tの欄から転記とする
For Each myRow In shfromm.Range("A1").CurrentRegion.Rows
If myRow.OutlineLevel = 2 Then
cm1.Value = myRow.EntireRow.Range("AB1").Value
Set cm1 = cm1.Offset(1)
End If
Next
さらに、ステップ実行で先に進んでみたところ、次の箇所で実行時エラー1004「ファイルにアクセルできません」とでます。
ファイルは確かにwbmを開いているので、存在するはずで、同じフォルダに同名のxlsファイルはないのですが、他に考えられる原因、ご指摘いただ
ければ、どうかお願いいたします。
'転記元ブックm保存
wbm.SaveAs Filepathm & sep & Left(shfromm.Range("A2"), 6) & shfromm.Range("Q2") & ".xls", FileFormat:=xlNormal
(usamiyu)
>いざ実行してみると、どこにも転記されません？？
確かにステップ実行するとうまくいくのに、普通に実行するとからぶりとか、もっと多くの場合はエラーになるとか
そういうことは、ありうるけど、今回は、そのようなことになるコードにもなっていないので、実際には
【ちゃんと転記されている】と思うね。ただし、【転記元ブックg】の、それを開いたときにたまたまアクティブに
なっていたシートに。 Set cm1 = Range("D13") この D13 は、どこのD13かな？
>実行時エラー1004「ファイルにアクセルできません」
1004になる可能性については少し調べてみるけど、とりあえず、wbm.SaveAs の上に
MsgBox Filepathm & sep & Left(shfromm.Range("A2"), 6) & shfromm.Range("Q2") & ".xls"
をいれて、いま保存しようとしている名前（フルパス）が、意図した文字列になっているかどうかを 確認してくれる？
(ぶらっと)
テーマとは関係がないけど
> MsgBox "題名に今月を入力しましたか？" 'vbOKonlyにしておいて、忘れていたら入力する?Exitはしたくない
ここで、まだ入力していなかったとしよう。で、OKボタンをおすね。 でも、そこで入力することはできないねぇ。そのまま、コードは実行されてしまう。
操作者にNo を許さないということなら、以下のような方法はあるけど。
Sub Sample()
Dim myText As String
Dim msg As String
myText = Range("A1").Value 'たとえば
Do
If Len(myText) = 0 Then
msg = "題名が入力されていません。必ず入力してください"
Else
msg = "題名を確認し、間違っていれば修正願います"
End If
myText = Application.InputBox(msg, "題名入力ボックス", myText, Type:=2)
If myText = "False" Then myText = ""
If Len(myText) > 0 Then Exit Do
Loop
End Sub
(ぶらっと)
>wbm.SaveAs Filepathm & sep & Left(shfromm.Range("A2"), 6) & shfromm.Range("Q2") & ".xls", FileFormat:=xlNormal
Filepathm は、最初のほうで、Filepathm = Application.GetOpenFilename("csvファイル,*.csv", , "ｍを開く") で取得しているね。
だから たとえば、 c:\〇〇〇\csvファイル名.csv という文字列だろうね？
Left(shfromm.Range("A2"), 6) が aaaaaa 、shfromm.Range("Q2") が xyz だったとしよう。
そうすると、Filepathm & sep & Left(shfromm.Range("A2"), 6) & shfromm.Range("Q2") & ".xls" は
c:\〇〇〇\csvファイル名.csv\aaaaaaxyz.xls ということになるね？ これは、ちょっと具合が悪くない？
(ぶらっと)
>Set cm1 = Range("D13") この D13 は、どこのD13かな？
わーっ！そうでしたね。きちんと修飾しなきゃいけなかったですね！なんだかどたばた混乱していて、すみません。
Set cm1 = .Range("D13")として、この点、解決しました。
それから下記の件は、先にコメントいただいてしまいましたが、書いていたので、そのまま記載します。
>MsgBox Filepathm & sep & Left(shfromm.Range("A2"), 6) & shfromm.Range("Q2") & ".xls"
ファイル名に余分なスペースが入っていたので、次のようにして、確認しました。
MsgBox Filepathm & sep & Left(shfromm.Range("A2"), 6) & RTrim(shfromm.Range("Q2")) & ".xls"
すると次のようになっています。多分FilepathmのところでCSV形式のファイル名が入っているのがいけないのでしょうか？
・・・どうしたらいいのでしょう？
D:\usamiyu\Report\○○￥25年度￥転記元ブックmの名前.csv￥201305△△.xls
^^^^^^
/ココ？？
>操作者にNo を許さないということなら なるほどぉ。自分がステップ実行していたからか、気づきませんでしたが、そこで入力することはできなかったんですね。 Sampleコードを参考にします。ありがとうございます。こういった処理は今までしたことがありませんでした。新しいことを たくさん教えていただけて、楽しいです(^^) (usamiyu)
フルパス文字列からのパス情報の取出しを含んで参考コードを３つほど。 TestA,TestB は実際のファイルがあってもなくても、単に文字列処理なのでエラーにはならないけど TestCは、実際のファイルを見に行っているので、なければエラーになる。
Sub TestA()
Dim fullPath As String
Dim myPath As String
Dim fNameShort As String
Dim fNameLong As String
Dim myExt As String
Dim wk As Variant
fullPath = "c:\aaaa\bbbb\cccc\XYZ.csv"
wk = Split(fullPath, "\")
fNameLong = wk(UBound(wk))
myPath = Replace(fullPath, fNameLong, "") '最後に \ がついているけど
fNameShort = Split(fNameLong, ".")(0)
myExt = Split(fNameLong, ".")(1)
MsgBox "フルパス:" & fullPath & vbLf & _
"パス:" & myPath & vbLf & _
"ファイル名(拡張子付):" & fNameLong & vbLf & _
"ファイル名(拡張子無):" & fNameShort & vbLf & _
"拡張子:" & myExt
End Sub
Sub TestB()
Dim fullPath As String
Dim myPath As String
Dim fNameShort As String
Dim fNameLong As String
Dim myExt As String
Dim wk As Variant
fullPath = "c:\aaaa\bbbb\cccc\XYZ.csv"
With CreateObject("Scripting.FileSystemObject")
myPath = .GetParentFolderName(fullPath) '最後に \ はつかないけど
fNameShort = .GetBaseName(fullPath)
myExt = .GetExtensionName(fullPath)
fNameLong = fNameShort & "." & myExt
End With
MsgBox "フルパス:" & fullPath & vbLf & _
"パス:" & myPath & vbLf & _
"ファイル名(拡張子付):" & fNameLong & vbLf & _
"ファイル名(拡張子無):" & fNameShort & vbLf & _
"拡張子:" & myExt
End Sub
Sub TestC()
Dim fullPath As String
Dim myFile As Object
Dim myPath As String
Dim fNameShort As String
Dim fNameLong As String
Dim myExt As String
Dim wk As Variant
fullPath = "c:\aaaa\bbbb\cccc\XYZ.csv"
With CreateObject("Scripting.FileSystemObject")
Set myFile = .getfile(fullPath)
myPath = myFile.parentfolder.path '最後に \ はつかないけど
fNameLong = myFile.Name
fNameShort = .GetBaseName(fullPath)
myExt = .GetExtensionName(fullPath)
End With
MsgBox "フルパス:" & fullPath & vbLf & _
"パス:" & myPath & vbLf & _
"ファイル名(拡張子付):" & fNameLong & vbLf & _
"ファイル名(拡張子無):" & fNameShort & vbLf & _
"拡張子:" & myExt
End Sub
(ぶらっと)
操作者にNo をさせないということで、Sampleコードを参考にして、画面描画停止したすぐ次の行に以下のように挿入してみました。
上手くいった？みたいです。
'--------------------------------------------------------
'題名に月数を入力したか確認して入力を促す
'--------------------------------------------------------
With shtod
myText = .Range("L1").Value '報告月
Do
If Val(Left(myText, 1)) <> Val(Month(Date)) Then '記載してある月が今月と違ったら
msg = "月数が入力されていません。必ず入力してください"
End If
myText = Application.InputBox(msg, "月数入力ボックス", myText, Type:=2)
If myText = "False" Then myText = ""
If Val(Left(myText, 1)) = Val(Month(Date)) Then .Range("L1").Value = myText
Exit Do
Loop
End With
それから、フルパス文字列からのパス情報の取出し、TestBを使ってみました。 「転記元、転記先ブックを保存する」以降のコードを次のように書き換えて、一応、最後まで完成しました。本当にありがとうございます！
'転記元ブックm保存
With CreateObject("Scripting.FileSystemObject")
myPath = .GetParentFolderName(Filepathm)
End With
wbm.SaveAs myPath & sep & Left(shfromm.Range("A2"), 6) & RTrim(shfromm.Range("Q2")) & ".xls", FileFormat:=xlNormal
wbm.Close False
'転記元ブックg保存
With CreateObject("Scripting.FileSystemObject")
myPath = .GetParentFolderName(Filepathg)
End With
wbg.SaveAs myPath & sep & Left(shfromg.Range("A2"), 6) & RTrim(shfromg.Range("Q2")) & ".xls", FileFormat:=xlNormal
wbg.Close False
Application.ScreenUpdating = True '画面描画再開
'調査票様式ブックを同じフォルダにA1セルの名前で保存
With CreateObject("Scripting.FileSystemObject")
myPath = .GetParentFolderName(FilePatht)
End With
With wbt
.SaveAs myPath & sep & Sheets(1).Range("A1") & ".xls"
.Sheets(1).PrintPreview
.Sheets(1).PrintOut
.Close
End With
(usamiyu)
ぶらっとさん、完成はしました。したのですが・・・もう少しの間、質問をつづけてもいいですか？ しつこくて申し訳ありません。（汗） もし、いい加減にして！と思われていたら、そう言ってくださると助かります。とりあえず、続けます。
この保存部分のコード、ブックが違うけれど、似たようなことを3回やっているのですが、サブルーチン化するとしたら、どうしたら よいのでしょうか。
最初、wbmとwbgについては保存方法がまったく同じなので、次のようにサブルーチンを書いてみました。 エラーは出ず、コードのとおり閉じたのですが、XL形式で保存されたファイルが見当たりません。他のフォルダも探してみましたが、 ない・・みたいです。
親プロシージャ Call Get_Mypath(wbm As Workbook, Filepathm As Variant, shfromm As Worksheet) Call Get_Mypath(wbg As Workbook, Filepathg As Variant, shfromg As Worksheet)
子プロシージャ
Private Sub Get_Mypath(wb As Workbook, Filepath As Variant, shfrom As Worksheet)
Dim myPath As String
Dim sep As String
With CreateObject("Scripting.FileSystemObject")
myPath = .GetParentFolderName(Filepath) '最後に \ はつかない
End With
wb.SaveAs myPath & sep & Left(shfrom.Range("A2"), 6) & RTrim(shfrom.Range("Q2")) & ".xls", FileFormat:=xlNormal
wb.Close False
End Sub
そもそも今回のメインコード、ブラッシュアップするとしたら、転記処理の部分自体もサブルーチン化できそうですよねぇ。 質問に来る前は混乱して、とてもそこまで手が回っていなかったんですが、ちょっと欲がでてきちゃいました^^;
(usamiyu)
全然、迷惑なんてことないので気にしないでね。 usamiyuさんの探求心と向上心、大好きですから。
テスト環境が事務所のＰＣにおいたままなので、明日まで待ってくれる？
(ぶらっと)
ぶらっとさん・・ありがとうございます！！ 嬉しくて、ありがたすぎて、泣けてきます〜。
はい、もちろんです。明日、またお話できるのを楽しみにしています＾＾
(usamiyu)
ちょっとばたばたしていて、今日、取組む時間がとれなかった、ごめん。
とりあえず、例のごとく
wb.SaveAs myPath & sep & Left(shfrom.Range("A2"), 6) & RTrim(shfrom.Range("Q2")) & ".xls", FileFormat:=xlNormal
のまえに、
MsgBox myPath & sep & Left(shfrom.Range("A2"), 6) & RTrim(shfrom.Range("Q2")) & ".xls"
をいれて、表示される文字列をメモして、処理後、その文字列のファイルが保存されていないかどうかを 確認してみよう。
ところで
Call Get_Mypath(wbm As Workbook, Filepathm As Variant, shfromm As Worksheet)
これは、コンパイルエラーになると思うけど？ 実際には
Call Get_Mypath(wbm, Filepathm, shfromm)
このように書いているんだよね？
(ぶらっと)
おつかれさまです。お忙しい中、お疲れのところ、お気に留めていただいて恐縮です。 私もちょうど、ごたついていたので、あれこれ片付けられて、かえってよかったです(^^)
>実際にはCall Get_Mypath(wbm, Filepathm, shfromm)このように書いているんだよね？
はいそうです。それで下記を確認してみました。
MsgBox myPath & sep & Left(shfrom.Range("A2"), 6) & RTrim(shfrom.Range("Q2")) & ".xls"
！あぁぁ・・・凡ミスです。sep = Application.PathSeparator が抜けていました。すみません。 こうするときちんと保存されました。
なので、とりあえずwbmとwbgについての保存はサブルーチン化できました。
wbtもなんとかできるでしょうか？
それと転記処理の部分もrm1、rm2、rg1、rg2として、同じような処理をしているので、ここもサブルーチンでなんとか なりそうでしょうか？
※お返事は急ぎません。ご都合のよいときにお願いできたらと思います。
(usamiyu)
すみません。↑の訂正です。
誤 rm1、rm2、rg1、rg2
正 cm1、cm2、cg1、cg2
(usamiyu)
転記処理の部分のサブルーチン化、次のようにしてみました。 とりあえずできたみたいですが、こんな感じの引数でまとめればいいのでしょうか？
親プロシージャ
Set cm1 = .Range("D13") '項目Mの「仮」の当期欄 ※種別jのデータが今存在しないのでD13種別tの欄から転記とする
Set cm2 = .Range("G13") '項目Mの「支出」の当期欄 ※種別jのデータが今存在しないのでG13種別tの欄から転記とする
Set cg1 = .Range("D19") '項目Gの「仮」の当期欄 ※種別jのデータが今存在しないのでD19種別tの欄から転記とする
Set cg2 = .Range("G19") '項目Gの「支出」の当期欄 ※種別jのデータが今存在しないのでG19種別tの欄から転記とする
Call Transfer_To_Report(cm1, cm2, shfromm)
Call Transfer_To_Report(cg1, cg2, shfromg)
子プロシージャ
Private Sub Transfer_To_Report(c1 As Range, c2 As Range, shfrom As Worksheet)
Dim myRow As Range
For Each myRow In shfrom.Range("A1").CurrentRegion.Rows
If myRow.OutlineLevel = 2 Then
c1.Value = myRow.EntireRow.Range("AB1").Value
Set c1 = c1.Offset(1)
End If
Next
For Each myRow In shfrom.Range("A1").CurrentRegion.Rows
If myRow.OutlineLevel = 2 Then
c2.Value = myRow.EntireRow.Range("AE1").Value
Set c2 = c2.Offset(1)
End If
Next
End Sub
(usamiyu)
親子関係の記述はこれで問題ないと思うね。
サブプロシジャ側、これでも、まったく問題ないけど、以下のように記述することもできるかな？
Private Sub Transfer_To_Report(c1 As Range, c2 As Range, shfrom As Worksheet)
Dim myRow As Range
For Each myRow In shfrom.Range("A1").CurrentRegion.Rows
If myRow.OutlineLevel = 2 Then
c1.Value = myRow.EntireRow.Range("AB1").Value
c2.Value = myRow.EntireRow.Range("AE1").Value
Set c1 = c1.Offset(1)
Set c2 = c2.Offset(1)
End If
Next
End Sub
(ぶらっと)
ああ！C1もC2も同じmyRowの中だからまとめられるんですねぇ。ありがとうございます。まとめます。 ご指摘いただけると「なるほど」と思うのですが、自分だと気づかないんです。つめが甘いですね。
それからwbtに関してはサブルーチン化する必要がない気がしてきましたので、このままとするつもりです。
最後にもうひとつ気になっている点、教えていただけますか。 （あ、再確認ですが、お返事はゆっくりで、もしよろしければということで構いません。）
上のほうのレスで >'題名に月数を入力したか確認して入力を促す というコードを記載したのですが、 題名に月数が入っていて、これは今月の数字と違っていたら入力を促すという目的で書いています。 その中で If Val(Left(myText, 1)) <> Val(Month(Date)) Then
としているのですが、これだと Left(myText, 1) で抜き出しているので、１〜９月はいいのですが、10月以降だと 比較できなくなっちゃいますよね。それで今 Val(Left(myText, 2))としました。
もともとVal関数を使ったのは、イミディエイトウィンドウでLeft(myText, 1) = Month(Date) としてみたら月数が 同じでもFalseが返ってきたので、Valで数値にしてみたのですが、LeftとMonth関数をヘルプで見てみるとどちらも 同じバリアント型の値を返すとあります。ただ内部形式はそれぞれStringとIntegerのVariantとあるので、この二つは 比較できないということなのでしょうか？
(usamiyu)
比較はできるよ。大丈夫。 ただし、Val(Left(myText, 2)) でもいいけど、文字列最初が 5月・・・ や 10月・・・になっているなら Val(MyText) でもい。
Sub Test1()
Dim s As String
s = "10月 あいうえお"
If Val(s) = Month(Date) Then
MsgBox "EQ"
Else
MsgBox "NE"
End If
s = "5月 あいうえお"
If Val(s) = Month(Date) Then
MsgBox "EQ"
Else
MsgBox "NE"
End If
End Sub
Sub Test2()
Dim s As String
s = "10月 あいうえお"
If Val(Left(s, 2)) = Month(Date) Then
MsgBox "EQ"
Else
MsgBox "NE"
End If
s = "5月 あいうえお"
If Val(Left(s, 2)) = Month(Date) Then
MsgBox "EQ"
Else
MsgBox "NE"
End If
End Sub
(ぶらっと)
試してみました。なるほどValを使うならTest1の形でいけますね。 でも >文字列最初が 5月 でないとだめなんですね。 s = "かきく5月 あいうえお" としてみたら "NE" になっちゃいました。最初に数値がないとだめってことなんでしょうか？ Val(s)が０になってしまいました。？？
実は様式に記載してある題名は、A1からI1まで結合して、「平成25年度 ○○報告（ 5月分）」というようなもので、 ここから月数の判定をする方法がわからなかったので、仕方なく、様式ブックの欄外の列に（ 以前と （ より後で値を分割して、 L1に 5月分） といった形で記載して、欄内はこれをconcatenate関数でくっつけて、しのぎました。 こんなことせずに判定する方法もありますか？
(usamiyu)
最初に 、「平成25年度 ○○報告（ 5月分）」といった文字列を見たときに、「扱いにくそう」と感じた。 この文字列は、それぞれ単独の項目が入っているセルを連結しているということなら、自分なら、年月を日付型で入力するセルを作っておき その日付型のデータから、Text関数も含んだ連結処理（ないしは、ＶＢＡで文字列を作り出し）をするね。そうすれば、文字列の中から 月を抽出しなくても、この日付セルの年月とDateをストレートに比較できるので。
と思うけど、コード案を２種類。（TestX と TestY）
Sub TestX1()
Dim s As String
Dim n As Long
Dim m As Long
' ( より後ろの文字列
s = " 5月分）"
n = InStr(s, "月")
If n > 0 Then
If IsNumeric(Mid(s, n - 2, 1)) Then
m = Val(Mid(s, n - 2, 2))
Else
m = Val(Mid(s, n - 1, 1))
End If
End If
MsgBox m
End Sub
Sub TestX2()
Dim s As String
Dim n As Long
Dim m As Long
' ( より後ろの文字列
s = " 10月分）"
n = InStr(s, "月")
If n > 0 Then
If IsNumeric(Mid(s, n - 2, 1)) Then
m = Val(Mid(s, n - 2, 2))
Else
m = Val(Mid(s, n - 1, 1))
End If
End If
MsgBox m
End Sub
Sub TestY1()
Dim s As String
Dim mt As Object
Dim n As Long
Dim m As Long
' 文字列全体
s = "平成25年度 ○○報告（ 5月分）"
With CreateObject("VBScript.RegExp")
.Pattern = "(\d{1,2})月"
Set mt = .Execute(s)
If mt.Count Then
m = mt.Item(0).submatches(0)
End If
End With
MsgBox m
End Sub
Sub TestY2()
Dim s As String
Dim mt As Object
Dim n As Long
Dim m As Long
'文字列全体
s = "平成25年度 ○○報告（ 10月分）"
With CreateObject("VBScript.RegExp")
.Pattern = "(\d{1,2})月"
Set mt = .Execute(s)
If mt.Count Then
m = mt.Item(0).submatches(0)
End If
End With
MsgBox m
End Sub
(ぶらっと)
扱いにくいですよね。 様式ブックの形式は私が変えるものではないのですが、報告提出後、本部では複数支店の報告をまとめて、 最終形を作るだろうと推測されるので、題名をちょっといじっても、大勢に影響ないだろうと思い、文字列を 分割しました。
>自分なら、年月を日付型で入力するセルを作っておき その日付型のデータから、Text関数も含んだ連結処理 >（ないしは、ＶＢＡで文字列を作り出し）をするね。
それで、コード案も試してみたのですが、上のお言葉のように処理してみたいです。 自分でできないかと考えたのですが・・・すみません。勉強不足でできません _(._.)_ 散々教えていただいているのに、ほんとに自分でも情けないんですが、もう少しだけ教えていただけるでしょうか。
おっしゃっているのは、こういうことではないのでしょうか？ まず、たとえばJ1に 4/1と入れて、表示形式を2013年4月にしておく。 それで、題名の部分は A1に =TEXT(J1,"ggge""年度""") & " ○○報告（" & TEXT(J1," m""月末現在）""")とする。
その後がわからないのですが、>日付セルの年月とDateをストレートに比較する というのはどうしたら？？ たとえば、下記のようにすると J1の値は表示形式で年月にしているだけなので、ストレートに比較ってできないのですが、 そもそも、J1セルの設定の仕方がまちがっていますか？
myText = .Range("J1").Value '報告月
If myText <> Date Then
(usamiyu)
たとえば
Sub Sample1() 'J1表示書式がyyyy年m月
Range("J1").Value = DateSerial(2013, 5, 1)
If Format(Date, "yyyy年m月") = Range("J1").Text Then
MsgBox "EQ"
Else
MsgBox "NE"
End If
Range("J1").Value = DateSerial(2013, 4, 1)
If Format(Date, "yyyy年m月") = Range("J1").Text Then
MsgBox "EQ"
Else
MsgBox "NE"
End If
End Sub
Sub Sample2() 'J1表示書式を問わない
Range("J1").Value = DateSerial(2013, 5, 1)
If Format(Date, "yyyy年m月") = Format(Range("J1").Value, "yyyy年m月") Then
MsgBox "EQ"
Else
MsgBox "NE"
End If
Range("J1").Value = DateSerial(2013, 4, 1)
If Format(Date, "yyyy年m月") = Format(Range("J1").Value, "yyyy年m月") Then
MsgBox "EQ"
Else
MsgBox "NE"
End If
End Sub
(ぶらっと)
ぶらっとさん ありがとうございます。 そうでしたかぁ・・Format関数で取り出して、ポイントはTextプロパティで比較するっていうことなんですね。 ValueとTextの違い、よくわかっていませんでした。おさらいします。昨夜は(＠_＠)状態でＳＯＳしてしまい、失礼しました。
sample1を次の用に組み込んで、上手くいきました。
With shtod
Do
If .Range("J1").Text <> Format(Date, "yyyy年m月") Then '記載してある月が今月と違ったら
msg = "月数が入力されていません。必ず入力してください"
End If
.Range("J1").Value = Application.InputBox(msg, "月数入力ボックス", .Range("J1").Text, Type:=2)
If .Range("J1").Value = "False" Then .Range("J1").Text = ""
If .Range("J1").Text = Format(Date, "yyyy年m月") Then Exit Do
Loop
End With
今回はお忙しいのに食い下がってしまい、大変ご面倒をおかけしました。やっと納得がいきました。心から感謝しています。 ありがとうございました。 私の探究心？にあきれはてて、もうかかわりたくないと思っていらっしゃるのではないかと不安ですが、 どうかこれに懲りず、次回もまた、ご指導くださいね。ね？
(usamiyu@ぶらっとさんファンの１人♪）
解決後にお邪魔します。
最後の部分ですが、当月以外を許さないなら、わたしならこうします。
操作者の手を煩わす必要はありません。
With shtod
If .Range("J1").Text <> Format(Date, "yyyy年m月") Then '記載してある月が今月と違ったら
'MsgBox "J1に本日の日付をセットします" 'メッセージを出す方が親切？
.Range("J1").Value = Date
End If
End With
−佳−
佳さん こんにちは〜。またお話できて嬉しいです。ありがとうございます。
確かにおっしゃるとおりですねぇ。 >当月以外を許さないなら、 この方がいいですね。
それで、私もこのロジックにしていたのですが、ちょっと、悩んでいるのは、 締め切りを守る人は、このロジックだと、すっと転記されて楽なんですが、 何かの事情で締め切りを守らず、当月以内に報告を出せなかった場合、どうしようかなぁと。 もう少し、自分でロジックを考え直す必要があると思っています。
(usamiyu)
ぶらっとさん 佳さん
上の件、悩んだ結果、意図する月数と違ったらExitさせることにしました。 一応、次のような結果になったので、アップしてみます。でも操作者にNoをさせないコードも勉強になりました。 ご指導ありがとうございました。
'--------------------------------------------------------
'報告月を確認する
'--------------------------------------------------------
With shtod
myMonth = .Range("J1").Text
If MsgBox("月数は" & myMonth & "これでいいですか？", vbQuestion + vbYesNo, "報告月確認") = vbYes Then
'題名を埋め込む
.Range("A1").Value = Format(.Range("J1"), "ggge年度") & "報告（ " & Month(.Range("J1")) & "月末現在）"
'YesならshikkouseiriListを子プロシージャから呼ぶ
Call ShikkouseiriList(shfromm)
Call ShikkouseiriList(shfromg)
Else
Exit Sub
End If
End With
(usamiyu)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.