[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『VBAの添削とシートが複数あると処理が重くなる』（nyanco）
初めて投稿させていただきます。VBA初心者です。
本やネットで勉強させていただき、VBAを作成したのですが、処理が遅く悩んでいます。
紙に書き出したり、時間を計測したりしてかなり考えたのですが、今の私の能力ですと解決方法が見つからず、頭がこんがらがってきました。
処理が早くなる書き方、これは間違っているということがあればご教授願いたく、よろしくお願いします。
１．プログラムの内容
１２シートあるデータを一つの集約シートにまとめたい。
１２のシートは、発注書になっていて、集約シートへデータをコピーする時に、データの作成処理も多少行っています。
集約シートから最終的にはCSV出力をします。
２．ブックの内容
１）マスタ（商品コードマスタ）
２）マスタ２（その他のマスタ）
３）集約シート
４）発注書１２枚（１枚に３５行の明細行）
３．困っていること
発注書シートがたくさんあると一行の書き出しに１秒以上の処理がかかっており、170行程度の時は10分以上かかってしまいました。
私のVBAの書き方が悪いのか、ロジック（処理順番）がまずいのか。
特に転記の所で2秒かかっています。
ほぼ全部のプログラム内容を書かせていただき、本当に申し訳ないのですが、どなたかご教授いただけましたらよろしくお願いします。
===================
Sub 全シート転記()
Dim i As Integer '発注カウンタ変数
Dim s As Integer '集約カウンタ変数
Dim n As Integer
Dim cntRec As Long
'集約カウンタ変数
Dim MaxRow As Integer
Dim SMaxRow As Integer
Dim Sws As Worksheet '集約シート
Dim Sar As Range '集約シートクリアセル
Const i_syohincode As Integer = 2 '発注シート 商品コードの列
Const i_syohinname As Integer = 3 '発注シート 商品名前の列
Const i_case As Integer = 7 '発注シート 箱数の列
Const i_bara As Integer = 8 '発注シート バラ数の列
Const i_ondo As Integer = 9 '発注シート バラ数の列
Const i_kaishi As String = "B13" '発注シート 明細開始セル
Const i_hattyubi As String = "C4" '発注シート 発注日
Const i_sagyobi As String = "F4" '発注シート 作業日
Const i_nouhinyoteibi As String = "I4" '発注シート 納品予定日
Const i_nouhinsouko As String = "C6" '発注シート 店舗の倉庫id
Const i_hasssobin As String = "H6" '発注書シート 発送便
Const s_kugiri As Integer = 1 '集約伝票区切
Const s_motosouko As Integer = 2 '振替元倉庫コード
Const s_mototanto As Integer = 3 '振替元倉庫コード
Const s_sakisouko As Integer = 4 '倉庫コード
Const s_sakitanto As Integer = 5 '振替先担当者コード
Const s_hiduke As Integer = 6 '振替日付
Const s_tekiyo As Integer = 7 '摘要
Const s_syohinocode As Integer = 8 '商品コード
Const s_case As Integer = 9 '箱数
Const s_bara As Integer = 10 '数量
Const s_motocode As String = "0110"
Const s_sizaicode As String = "0100"
Const s_tanto As String = "0900"
Set Sws = Worksheets("集約")
Set Sar = Sws.Range("A3:J10000")
'集約シートデータクリア
Sar.ClearContents
s = 3
'--------全シート並び替え------------
If MsgBox("全データを出力します", vbOKCancel + vbInformation, "集約データ出力") = vbOK Then
Debug.Print Time & " - スタート"
'画面更新、イベント、自動計算抑止
Call Automatic_processin_Stop
'--------作業日チェック
For n = 1 To Worksheets.Count
With Worksheets(n)
If .Name <> "マスタ" And .Name <> "商品マスタ" And .Name <> "集約" And _
.Range(i_sagyobi).Value = "" And .Range(i_kaishi).Value <> "" Then
MsgBox "シート「" & .Name & "」" & vbLf & "作業日を記入してください。" & vbLf & "処理を終了します。", vbOKOnly + vbCritical, "集約データ出力"
.Activate
Range(i_sagyobi).Select
Exit Sub
Else
.Activate
Call 商品並び替え
End If
End With
Next n
Else
MsgBox "処理をキャンセルしました", vbOKOnly + vbInformation, "集約データ出力"
Exit Sub
End If
Debug.Print Time & " - 作業日チェック"
'特定のシート以外シート分繰り返す データチェック
For n = 1 To Worksheets.Count
If Worksheets(n).Name <> "マスタ" And Worksheets(n).Name <> "商品マスタ" And Worksheets(n).Name <> "集約" Then
Worksheets(n).Activate
MaxRow = Cells(Rows.Count, i_syohincode).End(xlUp).Row
For i = 13 To MaxRow
'------商品コードが入っていない場合はシートスキップ
If Worksheets(n).Cells(i, i_syohincode).Value = "" Then
GoTo LABEL
End If
'------商品コードが入っていて、商品名が空欄の場合はエラー終了
With Worksheets(n)
If .Cells(i, i_syohincode).Value <> "" And .Cells(i, i_syohinname).Value = "" Then
MsgBox "商品コードと商品名が一致しません。商品マスタへ登録してください。" & vbLf & "エラー終了します。(No." & i - 12 & ")", vbCritical
Sar.ClearContents
Call Automatic_processin_Restart
.Rows(i).Select
Exit Sub
'------商品コードが入っていて、数量が空欄の場合はエラー終了
ElseIf .Cells(i, i_syohincode).Value <> "" And .Cells(i, i_case).Value = "" And .Cells(i, i_bara).Value = "" Then
MsgBox "数量が入力されておりません。明細を確認してください。" & vbLf & "エラー終了します。(No." & i - 12 & ")", vbCritical
Sar.ClearContents
Call Automatic_processin_Restart
.Rows(i).Select
Exit Sub
End If
End With
Next i
End If '１シート終了
DoEvents
Next n
Debug.Print Time & " - エラー終了チェック"
'特定のシート以外、シート分繰り返す
For n = 1 To Worksheets.Count
If Worksheets(n).Name <> "マスタ" And Worksheets(n).Name <> "商品マスタ" And Worksheets(n).Name <> "集約" Then
Worksheets(n).Activate
MaxRow = Cells(Rows.Count, i_syohincode).End(xlUp).Row
For i = 13 To MaxRow
'------商品コードが入っていない場合はシートスキップ
If Worksheets(n).Cells(i, i_syohincode).Value = "" Then
GoTo LABEL
End If
'------伝票区切り
With Worksheets(n)
If i = 13 Then '一行目の場合
Sws.Cells(s, s_kugiri).Value = "*"
'------伝票区切り資材
ElseIf .Cells(i, i_syohincode).Value >= 6000000 And .Cells(i, i_syohincode).Value <= 6999999 And _
.Cells(i - 1, i_syohincode).Value >= 4000000 And .Cells(i - 1, i_syohincode).Value <= 5999999 Then
Sws.Cells(s, s_kugiri).Value = "*"
End If
Debug.Print Time & " - 伝票区切り"
'------転記 倉庫コード商品or資材
If .Cells(i, i_syohincode).Value >= 4000000 And .Cells(i, i_syohincode).Value <= 5999999 Then
Sws.Cells(s, s_motosouko).Value = s_motocode
Else
Sws.Cells(s, s_motosouko).Value = s_sizaicode
End If
End With
DoEvents
Debug.Print Time & " - 倉庫コード分岐"
'------転記
With Sws
.Cells(s, s_mototanto).Value = s_tanto '振替元担当者コード
.Cells(s, s_sakitanto).Value = s_tanto '振替先担当者コード
.Cells(s, s_sakisouko).Value = Worksheets(n).Range(i_nouhinsouko).Value '振替先倉庫コード
.Cells(s, s_hiduke).Value = Worksheets(n).Range(i_sagyobi).Value '振替日付⇒作業日
.Cells(s, s_syohinocode).Value = Worksheets(n).Cells(i, i_syohincode).Value '商品コード
.Cells(s, s_case).Value = Worksheets(n).Cells(i, i_case).Value '箱数
End With
Debug.Print Time & " - 明細転記"
'------摘要欄記述分岐
With Worksheets(n)
If .Range(i_hasssobin).Value = "1便" Then
Sws.Cells(s, s_tekiyo).Value = "移動 1便" & "（予定日：" & .Range(i_nouhinyoteibi).Value & "）"
ElseIf .Range(i_hasssobin).Value = "2便" Then
Sws.Cells(s, s_tekiyo).Value = "移動 2便" & "（予定日：" & .Range(i_nouhinyoteibi).Value & "）"
Else
Sws.Cells(s, s_tekiyo).Value = "移動" & "（予定日：" & .Range(i_nouhinyoteibi).Value & "）"
End If
DoEvents
Debug.Print Time & " - 摘要欄転記"
'------バラ分岐
If .Cells(i, i_case).Value > 0 And .Cells(i, i_bara).Value > 0 Then
s = s + 1
Sws.Range(Sws.Cells(s, s_motosouko), Sws.Cells(s, s_syohinocode)).Value _
= Sws.Range(Sws.Cells(s - 1, s_motosouko), Sws.Cells(s - 1, s_syohinocode)).Value '振替元倉庫コードから商品コード
Sws.Cells(s, s_bara).Value = .Cells(i, i_bara).Value 'バラ数
Else
Sws.Cells(s, s_bara).Value = .Cells(i, i_bara).Value 'バラ数
End If
End With
Debug.Print Time & " - バラ分岐"
s = s + 1
cntRec = cntRec + 1
Application.StatusBar = "処理実行中．．．．(現在 " & cntRec & "件)"
Next i
End If '１シート転記の終了
DoEvents
LABEL: Next n
Application.StatusBar = False
'画面更新、イベント、自動計算再開
Call Automatic_processin_Restart
Debug.Print Time & " - 終了"
MsgBox "出力終了。" & vbLf & "これ以降に数量の修正があった場合は、" & vbLf & "必ず伝票の修正をお願いします。", vbInformation, "集約データ出力"
'--------yesの場合、WRITE_CSVFile3モジュール呼び出し
If MsgBox("このままcsvに書き出ししますか？", vbOKCancel, "集約データ出力") = vbOK Then
Sheets("集約").Select
Call WRITE_CSVFile
End If
End Sub
＜ 使用 Excel：Excel2013、使用 OS：Windows7 ＞
nyanco さん サンプルファイル置けますか？ http://ww10.puny.jp/uploader/ できるだけ、掲示板内への書き込みで、やりとりするよう、心掛けます。"(-""-)" （マリオ） 2016/03/23(水) 22:43
早速ありがとうございます。（涙）
テストデータを作成しました。
＜閉じました＞
ちょっと動作が早くなってしまったかもしれませんが・・
スペックのいいパソコンですとちょっと早くなるかもしれません。
職場ですとかなり重い動作になります。ほんとに１０分以上かかります。
プログラム内にwithが混在してるかもしれませんが、あった方がいいのかないほうがいいのか、
試して汚くなっているところがあるかと思います。（汗）
どうぞよろしくおねがいいたします。。。
（nyanco） 2016/03/23(水) 23:42
ダウンロードしました。明日見ます。 （マリオ） 2016/03/24(木) 00:42
それと細かい話では、
If A And B And C And D Then
などとした場合、A が Falseであっても、B,C,Dも必ず評価されてしまうので、
If のネストで書いた方が（速度上は）有利だという話はあります。
ただ、それが致命的なものではないと思います。
シートへのアクセス量のほうが大きいと思います。
（γ） 2016/03/24(木) 07:27
まず、Goto文の飛び先が×！ 2つ目のnのループ内でシートスキップする際、3つ目のループ末に飛んでます。
これ、飛び先のNext文がたまたま同じであり、インタプリンタ言語だから動いているだけであり、反則技です。
こんな使い方をする人には、一生Goto文の使用を禁止すべきレベルです。
次に、シート名の判定文が何度もでてきて、冗長です。一度見れば不要シートと判るでしょう。
シート名の判定も片手落ちに見えます。
＞ If .Name <> "マスタ" And .Name <> "商品マスタ" And .Name <> "集約" And _ ＞ .Range(i_sagyobi).Value = "" And .Range(i_kaishi).Value <> "" Then
例えばここは、シート名が"マスタ"の場合でもElseに飛び、「商品並び替え」プロシジャが実行されます。
しかし、マスタって普通は毎回並び替えたりしませんよね？ 無駄な処理では？
後半のセル判定も、片方だけ条件成立するとElseに飛びますが、それで良いのですか？ 両方揃っていないと駄目では？
無理に1行にまとめず、多段階にすべき。(というか、同じ判定をしなくて済むコーディングにすべき）
コードや数量のエラー判定も、1件でも間違っているとMsgBox表示して終了です。間違っている所を直して再実行すると、
次に間違ったところでまた止まりますが、面倒ではないですか？ 最初にまず全ての入力が正しいかだけ全て判定し、
駄目な箇所を列挙し、実際の処理部分ではIf文を削る。 これなら間違いを一発で全部直せるし、処理も速くなりますよ。
13行目から末尾までループしているところで、ループ内で13行目だったら？、というIf文を使っていますが、
だったら13行目と14行目以降の処理を分けてしまえば、行数分のIf文を削れますよね？ ここも冗長。
ループ内でWith文を使っている箇所は、Sws等の変数に割り当てているものはWithせず、他方に使うべき。
そうすれば、For文の直下でWorksheets(n)でWithすれば、頻繁にWith対象を切り替える必要は無さそう。
Automatic_processin_StopとRestartはコードが無いですが、おそらく自動計算や表示更新を抑止し戻すプロシジャかと思います。
これ、Goto文禁止とは反しますが、Resetを終了時1回でも良いのでは？ 途中でResetせず抜けている箇所がありますよ。バグの元。
あとは、遅いと言いながらDebug.Printを多用していますが、この命令はデバッグ中だからですよね？
こんなにいっぱい出力すると、これだけでもかなりの遅さの原因になりますから。
Application.StatusBarの表示も、遅くなる原因になります。1万行もあるのだがら、500件に1回にするとか、回数を減らすべきです。
（???） 2016/03/24(木) 09:44
やたら、Constで定数を定義しているので、読みづらいです。見る気が失せます。
「シート６枚、それぞれ３行分のデータ」で十分遅いです。
検証するのに、１２枚もシートいらないですよね？
確かに、シートが増えると極端に遅くなりますね。
時間計測して、遅いのは、コードの■〜■間です。
■〜■間を集中的に修正してください。
修正の方向としては、
配列をセルに一括で代入ですかね。
下記URL先を参照して、がんばってください。とても見てられません。
https://www.moug.net/tech/exvba/0100049.html
Option Explicit
Declare Function GetTickCount Lib "KERNEL32.DLL" () As Long
Sub 全シート転記()
Dim i As Integer '明細側カウンタ変数
Dim s As Integer '集約側カウンタ変数
Dim n As Integer
Dim cntRec As Long
'集約側カウンタ変数
Dim MaxRow As Integer
Dim SMaxRow As Integer
Dim Sws As Worksheet '集約シート
Dim Sar As Range '集約シートクリアセル
Const i_syohincode As Integer = 2 'シート 商品コードの列
Const i_syohinname As Integer = 3 'シート 商品名前の列
Const i_case As Integer = 7 'シート 箱数の列
Const i_bara As Integer = 8 'シート バラ数の列
Const i_ondo As Integer = 9 'シート バラ数の列
Const i_kaishi As String = "B13" 'シート 明細開始セル
Const i_hattyubi As String = "C4" 'シート 発注日
Const i_sagyobi As String = "F4" 'シート 作業日
Const i_nouhinyoteibi As String = "I4" 'シート 納品予定日
Const i_nouhinsouko As String = "C6" 'シート 店舗の倉庫id
Const i_hasssobin As String = "H6" 'シート 発送便
Const s_kugiri As Integer = 1 '集約伝票区切
Const s_motosouko As Integer = 2 '振替元倉庫コード
Const s_mototanto As Integer = 3 '振替元倉庫コード
Const s_sakisouko As Integer = 4 '集約倉庫コード
Const s_sakitanto As Integer = 5 '集約振替先担当者コード
Const s_hiduke As Integer = 6 '集約振替日付
Const s_tekiyo As Integer = 7 '摘要
Const s_syohinocode As Integer = 8 '商品コード
Const s_case As Integer = 9 '箱数
Const s_bara As Integer = 10 '数量
Const s_motocode As String = "0110"
Const s_sizaicode As String = "0100"
Const s_tanto As String = "0900"
Set Sws = Worksheets("集約")
Set Sar = Sws.Range("A3:J10000")
'集約シートデータクリア
Sar.ClearContents
s = 3
'--------全シート並び替え------------
If MsgBox("全データを出力します", vbOKCancel + vbInformation, "集約データ出力") = vbOK Then
'****************************************
Call Automatic_processin_Stop '画面更新、イベント、自動計算抑止
'****************************************
'--------作業日チェック
For n = 1 To Worksheets.Count
With Worksheets(n)
If .Name <> "マスタ" And .Name <> "商品マスタ" And .Name <> "集約" And _
.Range(i_sagyobi).Value = "" And .Range(i_kaishi).Value <> "" Then
MsgBox "シート「" & .Name & "」" & vbLf & "作業日を記入してください。" & vbLf & _
"処理を終了します。", vbOKOnly + vbCritical, "集約データ出力"
.Activate
Range(i_sagyobi).Select
Exit Sub
Else
.Activate
'****************************************
Call 商品並び替え
'****************************************
End If
End With
Next n
Else
MsgBox "処理をキャンセルしました", vbOKOnly + vbInformation, "集約データ出力"
Exit Sub
End If
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'シート分繰り返す データチェック
For n = 1 To Worksheets.Count
If Worksheets(n).Name <> "マスタ" And Worksheets(n).Name <> "商品マスタ" And Worksheets(n).Name <> "集約" Then
Worksheets(n).Activate
MaxRow = Cells(Rows.Count, i_syohincode).End(xlUp).Row
For i = 13 To MaxRow
'------商品コードが入っていない場合はシートスキップ
If Worksheets(n).Cells(i, i_syohincode).Value = "" Then
GoTo LABEL
End If
With Worksheets(n)
'------商品コードが入っていて、商品名が空欄の場合はエラー終了
If .Cells(i, i_syohincode).Value <> "" And .Cells(i, i_syohinname).Value = "" Then
MsgBox "商品コードと商品名が一致しません。商品マスタへ登録してください。" & vbLf & _
"エラー終了します。(No." & i - 12 & ")", vbCritical
Sar.ClearContents
.Rows(i).Select
Exit Sub
'------商品コードが入っていて、数量が空欄の場合はエラー終了
ElseIf .Cells(i, i_syohincode).Value <> "" And .Cells(i, i_case).Value = "" And .Cells(i, i_bara).Value = "" Then
MsgBox "数量が入力されておりません。明細を確認してください。" & vbLf & _
"エラー終了します。(No." & i - 12 & ")", vbCritical
Sar.ClearContents
.Rows(i).Select
Exit Sub
'------商品コードが入っていて、温度帯が空欄の場合はエラー終了
ElseIf .Cells(i, i_syohincode).Value <> "" And .Cells(i, i_ondo).Value = "" Then
MsgBox "温度帯が登録されておりません。商品マスタを確認してください。" & vbLf & _
"エラー終了します。(No." & i - 12 & ")", vbCritical
Sar.ClearContents
.Rows(i).Select
Exit Sub
End If
End With
Next i
End If '１シート終了
DoEvents
Next n
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Dim StartTime As Long: StartTime = GetTickCount '●●●時間計測開始（ミリ秒）
'シート分繰り返す
For n = 1 To Worksheets.Count
If Worksheets(n).Name = "マスタ" Then GoTo LABEL
If Worksheets(n).Name = "商品マスタ" Then GoTo LABEL
If Worksheets(n).Name = "集約" Then GoTo LABEL
MaxRow = Worksheets(n).Cells(Rows.Count, i_syohincode).End(xlUp).Row
'■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
For i = 13 To MaxRow
'------商品コードが入っていない場合はシートスキップ
If Worksheets(n).Cells(i, i_syohincode).Value = "" Then
GoTo LABEL
End If
With Worksheets(n)
'------伝票区切り
If i = 13 Then '一行目の場合
Sws.Cells(s, s_kugiri).Value = "*"
'------伝票区切り資材
ElseIf .Cells(i, i_syohincode).Value >= 6000000 And _
.Cells(i, i_syohincode).Value <= 6999999 And _
.Cells(i - 1, i_syohincode).Value >= 4000000 And _
.Cells(i - 1, i_syohincode).Value <= 5999999 Then
Sws.Cells(s, s_kugiri).Value = "*"
End If
'------転記 倉庫コード商品(110)or資材(100)
If .Cells(i, i_syohincode).Value >= 4000000 And _
.Cells(i, i_syohincode).Value <= 5999999 Then
Sws.Cells(s, s_motosouko).Value = s_motocode
Else
Sws.Cells(s, s_motosouko).Value = s_sizaicode
End If
End With
'------転記
With Sws
Union(.Cells(s, s_mototanto), .Cells(s, s_sakitanto)).Value = s_tanto '振替元担当者コード
.Cells(s, s_sakisouko).Value = Worksheets(n).Range(i_nouhinsouko).Value '振替先倉庫コード
.Cells(s, s_hiduke).Value = Worksheets(n).Range(i_sagyobi).Value '振替日付⇒作業日
.Cells(s, s_syohinocode).Value = Worksheets(n).Cells(i, i_syohincode).Value '商品コード
.Cells(s, s_case).Value = Worksheets(n).Cells(i, i_case).Value '箱数
End With
'------摘要欄記述分岐
With Worksheets(n)
If .Range(i_hasssobin).Value = "1便" Then
Sws.Cells(s, s_tekiyo).Value = "あああああああ 1便" & "（納品予定日：" & .Range(i_nouhinyoteibi).Value & "）"
ElseIf .Range(i_hasssobin).Value = "2便" Then
Sws.Cells(s, s_tekiyo).Value = "あああああああ 2便" & "（納品予定日：" & .Range(i_nouhinyoteibi).Value & "）"
Else
Sws.Cells(s, s_tekiyo).Value = "あああああああ" & "（納品予定日：" & .Range(i_nouhinyoteibi).Value & "）"
End If
'------バラ分岐
If .Cells(i, i_case).Value > 0 And .Cells(i, i_bara).Value > 0 Then
s = s + 1
Sws.Range(Sws.Cells(s, s_motosouko), Sws.Cells(s, s_syohinocode)).Value = _
Sws.Range(Sws.Cells(s - 1, s_motosouko), Sws.Cells(s - 1, s_syohinocode)).Value '振替元倉庫コードから商品コード
Sws.Cells(s, s_bara).Value = .Cells(i, i_bara).Value 'バラ数
Else
Sws.Cells(s, s_bara).Value = .Cells(i, i_bara).Value 'バラ数
End If
End With
s = s + 1
cntRec = cntRec + 1
Application.StatusBar = "処理実行中．．．．(現在 " & cntRec & "件)"
Next i
'■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
LABEL:
Next n
Application.StatusBar = False
'***********************************
Call Automatic_processin_Restart '画面更新、イベント、自動計算再開
'***********************************
MsgBox (GetTickCount - StartTime) & "[ミリ秒]" '●●●時間計測終了（ミリ秒）
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
MsgBox "出力終了。" & vbLf & "これ以降に数量の修正があった場合は、" & vbLf & _
"修正をお願いします。", vbInformation, "集約データ出力"
'--------yesの場合、WRITE_CSVFile3モジュール呼び出し
If MsgBox("このままcsvに書き出ししますか？", vbOKCancel, "集約データ出力") = vbOK Then
Sheets("集約").Select
'***********************************
Call WRITE_CSVFile
'***********************************
End If
End Sub
Sub 商品並び替え()
Dim MySheet As String
MySheet = ActiveSheet.Name
With ActiveWorkbook.Worksheets(MySheet)
.sort.SortFields.Clear
.sort.SetRange Range("B12:J47")
.sort.Header = xlYes
'温度帯で並び替え
.sort.SortFields.Add Key:=Range("I13"), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal, _
CustomOrder:="常温,冷蔵,冷凍"
'商品コードで並び替え
.sort.SortFields.Add Key:=Range("B13"), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
.sort.MatchCase = False
.sort.Orientation = xlTopToBottom
.sort.SortMethod = xlPinYin
.sort.Apply
End With
End Sub
Sub Automatic_processin_Stop()
With Application '画面更新、イベント、自動計算抑止
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub
Sub Automatic_processin_Restart()
With Application '画面更新、イベント、自動計算再開
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
（マリオ） 2016/03/24(木) 19:47
●γさま
＞シート書き込みの回数を減らす工夫をするということでしょうね。
＞一般論として申し上げれば、
＞・行毎に纏めて書き込む、
＞・さらに可能なら、結果を配列にもっておいて、最後に一度だけシートに書き込む
＞シートへのアクセス量のほうが大きいと思います。
なるほど、そういう考え方があるんですね。
考慮しながら、コードを考えてみます！ありがとうございます。
●???さま
細かく確認して頂き、大変にありがとうございます。
＞Goto文の飛び先が×！
すみません！飛び先を間違っていました。最初一つだったものを二つに分けたので、気付かずにいました・・。
確かに使うなレベルですね。Labelを分け、修正いたしました。
＞シート名の判定文が何度もでてきて、冗長です。一度見れば不要シートと判るでしょう。
チェックの作業と転記の作業をわけたので、その時に何度もシートの処理をしなくてはならないと思っていたのですが、違うやり方があるのですね。また色々と試してみます。
＞無理に1行にまとめず、多段階にすべき。
これも無理やり一つにしていました。（汗）
こちらは分けました。ありがとうございます。
＞最初にまず全ての入力が正しいかだけ全て判定し、
駄目な箇所を列挙し、実際の処理部分ではIf文を削る。 これなら間違いを一発で全部直せるし、処理も速くなりますよ。
ご進言いただいた内容がとても理想的なのですが、今の私の能力ではその書き方がわかりません。。。
（なので、今は１件１件にしています）
でも、頂いたロジックを元に、考えてみます。
＞13行目から末尾までループしているところで、ループ内で13行目だったら？、というIf文を使っていますが、
分けるコードを考えてみたのですが、今の私ですとIFで１３行目の作業と１４行目からの作業を分ける書き方しか思いつかない為、もう少し考えてみます！
＞With文を使っている箇所
なるほど、なるほど。一つの処理にそれぞれ書かなくてはならないのかと思っていましたが、
ひとくくりにしてもいいのですね！！Swsをやめて、くくれるところはwithでひとまとめにくくりました！
コードが見やすくなりました！！！
＞Goto文禁止とは反しますが、Resetを終了時1回でも良いのでは？
なるほど・・Goto多くなってしまうけど今の状態では必要ですよね。取り急ぎその方法を取り入れます。
＞途中でResetせず抜けている箇所があります
一番最初ですね。すみません。
Debug.Printは、デバック中なのでそのまま載せました。
Application.StatusBarの表示も、シートごとにしてみようと思います。
すぐに修正できるところは、修正しました。少し動作が落ち着いたように感じます。（私の気持ちが？笑）
本当にありがとうございます。
●マリオさま
貴重なお時間をいただきまして、本当に申し訳ございません！
Labelは間違っておりました。マリオ様の仰る通り、同じように修正しました。
定数の定義は、やらない場合、片方定義、両方定義などの時間を測ってみましたら、全て定義が早かったので
そのようにいたしました。その前に、そもそも書き方がおかしいのでそういう次元じゃないですよね。
そのままお渡ししてしまったこと、申し訳ございません。
シートは、私の検証では３枚と１２枚でやっております。
しかしながら、３枚と１２枚では速度が変わってしまいますので、確認して頂くために１２枚つけた方が良いかと
そのようにさせていただきました。
（最終的には１２枚以上使用しますので。。）
配慮が足らず、申し訳ございません。
＞修正の方向としては、配列をセルに一括で代入ですかね。
なるほど、そのような考え方に気が付かず、大変に勉強になりました。
貴重なリンクまで頂きまして、ありがとうございます！！！
読んですぐ理解できる内容ではないのですが、何度も読んで実践してみます！！
また、コードのコメントの書き方も教えていただきましてありがとうございます。
とても見やすいです！！すぐ取り入れます。ありがとうございます。
本当に皆様、ありがとうございます。
ご意見がいただけて、本当に、本当に嬉しいです。
頂いたご意見を考えて、試してみて、また悩んだら相談させていただきますね。
（nyanco） 2016/03/24(木) 20:48
nyanco さん
参考にしてください。
Sub test()
Dim x(1 To 5) As String
x(1) = "た"
x(2) = "ち"
x(3) = "つ"
x(4) = "て"
x(5) = "と"
Sheets("Sheet1").Range("A1:E1") = x
End Sub
Sub test2()
Dim z As Long
z = 3
ReDim x(1 To z, 1 To 5) As String
x(1, 1) = "あ"
x(1, 2) = "い"
x(1, 3) = "う"
x(1, 4) = "え"
x(1, 5) = "お"
x(2, 1) = "か"
x(2, 2) = "き"
x(2, 3) = "く"
x(2, 4) = "け"
x(2, 5) = "こ"
x(3, 1) = "さ"
x(3, 2) = "し"
x(3, 3) = "す"
x(3, 4) = "せ"
x(3, 5) = "そ"
Sheets("Sheet1").Range("A1:E3") = x
End Sub
（マリオ） 2016/03/24(木) 21:52
わわわわ！試してみました！！
スゲええええええ！！！
こういうこともできるんですね！！
縦と、セルの指定もできるんですね！
早速色々と勉強してみて、使えるようにします！！
遅くまでありがとうございます!!!!!
皆様の仰っている「配列に代入」を今まで知らずになかなか検索もできず、
今回教えていただいたリンク先より言葉の使い方も分かりました。
（きっと本にあっても理解していないのでスルーしていたと思います）
そのため、検索もできるようになったので色々と学んでいきます。
他の質問のコードも学ばせていただきますね！
ありがとうございます。(^o^)
（nyanco） 2016/03/24(木) 22:37
朝方、考え方だけコメントしました。
シート毎に配列を作って、それを纏めて集約シートに転記するのが良いかもしれませんね。 骨子となる部分だけ載せますので、参考にしてください。（内容を保証するものではありません）
ws2（集約シート）や、 そのなかでの書き込み位置を示す変数 p は モジュールレベルで宣言しておきます。
169件であれば、全体でも 数秒程度で実行できるはずです。
Function 転記(ws As Worksheet)
Dim maxRow As Long
Dim i As Long
Dim mat(1 To 35, 1 To 10)
Dim k As Long
k = 1
maxRow = ws.Cells(ws.Rows.Count, i_syohincode).End(xlUp).Row
If maxRow = 12 Then Exit Function
For i = 13 To maxRow
'------伝票区切り
With ws
If ws.Cells(i, i_syohincode).Value = "" Then
Exit Function
End If
'------伝票区切り資材
If i = 13 Then '一行目の場合
mat(k, s_kugiri) = "*"
Else
If .Cells(i, i_syohincode).Value >= 6000000 _
And .Cells(i, i_syohincode).Value <= 6999999 Then
If .Cells(i - 1, i_syohincode).Value >= 4000000 _
And .Cells(i - 1, i_syohincode).Value <= 5999999 Then
mat(k, s_kugiri) = "*"
End If
End If
End If
'------転記 倉庫コード商品or資材
If .Cells(i, i_syohincode).Value >= 4000000 _
And .Cells(i, i_syohincode).Value <= 5999999 Then
mat(k, s_motosouko) = s_motocode
Else
mat(k, s_motosouko) = s_sizaicode
End If
'------転記
mat(k, s_mototanto) = s_tanto '振替元担当者コード
mat(k, s_sakitanto) = s_tanto '振替先担当者コード
mat(k, s_sakisouko) = .Range(i_nouhinsouko).Value '振替先倉庫コード
mat(k, s_hiduke) = .Range(i_sagyobi).Value '振替日付⇒作業日
mat(k, s_syohinocode) = .Cells(i, i_syohincode).Value '商品コード
mat(k, s_case) = .Cells(i, i_case).Value '箱数
'------メモ欄記述分岐
Select Case .Range(i_hasssobin).Value
Case "1便"
mat(k, s_tekiyo) = "あああああああ 1便" _
& "（予定日：" & .Range(i_nouhinyoteibi).Value & "）"
Case "2便"
mat(k, s_tekiyo) = "あああああああ 2便" _
& "（予定日：" & .Range(i_nouhinyoteibi).Value & "）"
Case Else
mat(k, s_tekiyo) = "あああああああ" _
& "（予定日：" & .Range(i_nouhinyoteibi).Value & "）"
End Select
'------バラ分岐
If .Cells(i, i_case).Value > 0 And .Cells(i, i_bara).Value > 0 Then
s = s + 1
For j = s_motosouko To s_syohinocode '振替元倉庫コードから商品コード
mat(k, j) = mat(k - 1, j)
Next
mat(k, s_bara) = .Cells(i, i_bara).Value 'バラ数
Else
mat(k, s_bara) = .Cells(i, i_bara).Value 'バラ数
End If
k = k + 1
End With
Next
ws2.Cells(p, 1).Resize(k - 1, 10).Value = mat
p = p + k - 1
End Function
（γ） 2016/03/24(木) 23:14
CSV保存を除いて3秒くらいで終わる処理です。
＞使えるように週末勉強します！
是非がんばってください。
（γ） 2016/03/25(金) 22:11
To にゃんこ さん
２０シート（フルにデータを格納）の情報を配列に入れて、 集約シートへの書き込みを１回だけにしたところ、 所要時間は０．１５秒程でした。１秒かかりません（csv保存を除く）。 ***************************************************************** ■コードを載せるのは、簡単なのですが…。
現在、掲示板には、コードで使用するサンプルデータが書き込まれていません。 ファイルをダウンロードするサイト（ 2016/03/23(水) 23:42の記事を参照） が閉鎖されたら、この掲示板の書き込みだけを見ている人は、 どのようなサンプルデータで、コードを実行するのか分からないなります。
★最低限のサンプルデータ（シートレイアウト）を載せてください。 ・マスタシート ・商品マスタシート ・集約シート ・その他のシート（C,I列で使用している関数、H6のリスト）
シートレイアウトを載せるのに、次のマクロを使用すると簡単です。 [[20110209184943]] 『[談]シートレイアウトの投稿どうしてますか？』（ｍｏｍｏ）
★最低限のデータが掲示板に書き込まれたら、コードをアップしたいと思います。 （マリオ） 2016/03/26(土) 00:22
このスレッドでは主要なコードは提示されていますし、、
質問のテーマとしては十分提示、説明されています。
その結果、皆さんからコード改善提案がされています。
なお、私の、3秒でできるとかは、どうでもよいことでした。
しかし、そのことで質問者さんを振り回すのはどうなんでしょうか。
もともとそれを指示されたのはマリオさんですし、
＞とても見てられません。
とおっしゃったのもあなたです。
質問者さんは、まずは、今までの提示情報を参考にされることを優先されてはどうかと思います。
（γ） 2016/03/26(土) 07:29
サンプルデータです。
(1)（シート名：マスタ）空白でよし
(2)（シート名：商品マスタ）空白でよし
(3)（シート名：集約）集約先のシートです。データ転記は、A3セル以降。（タイトルとなる1,2行目を下記に記載）
**************************************************************************************************************
|[A] |[B] |[C] |[D] |[E] |[F] |[G] |[H] |[I] |[J]
[1]|伝票区切|振替元倉庫コード|元担当者code|振替先倉庫コード|先担当者code|振替日付|摘要|商品コード|箱数|数量
[2]|A |B |C |D |E |F |G |H |I |J
***************************************************************************************************************
(4)（シート名：任意）集約元のシート。これを複製して12シート作成する←シート名は「1」〜「12」
|[A]|[B] |[C] |[D]|[E]|[F] |[G] |[H] |[I]
[1] | | | | | | | | |
[2] | | | | | | | | |
[3] | | | | | | | | |
[4] | | | | | |2016/3/26| | |
[5] | | | | | | | | |
[6] | | | 301| | | | |1便 |
[7] | | | | | | | | |
[8] | | | | | | | | |
[9] | | | | | | | | |
[10]| | | | | | | | |
[11]| | | | | | | | |
[12]|NO |商品コード|商品名 | | | |ケース|バラ|温度帯
[13]| 1| 1111111|商品名1| | | | 2 | 1 |冷凍
[14]| 2| 2222222|商品名2| | | | 2 | 1 |冷蔵
[15]| 3| 3333333|商品名3| | | | 2 | 1 |常温
（マリオ） 2016/03/26(土) 09:20
To γさん 私は、未熟者です （マリオ） 2016/03/26(土) 09:26
（γ） 2016/03/26(土) 13:25
色々と考えていただき、ありがとうございます。
会話のペースに追いついていないので、少しお時間をください。
まだγさまにいただいた所で、わからない部分があって考え中なのと、
やはりシートの分岐をどうするかで悩んでおり、
ここに書き込む時間が今ちょっとないのですみません。
私が定数で書き込まなければ良かったんですよねっ！
でもそれに気づけたのも皆様のお陰です。
真剣に考えていただいて本当に感謝しています。
ありがとうございます。m(_ _)m
マリオさまデータの情報をアップしていただきありがとうございます！
取り急ぎで失礼致します。
（nyanco） 2016/03/26(土) 15:48
追伸：
＞私が定数で書き込まなければ良かったんですよねっ！
そんなことないでしょう。一つのやり方ではありますね。
（γ） 2016/03/26(土) 20:13
To nyanco さん
たくさん悩んで、成長してください(^^♪ nyancoさんも、真剣に取り組まれている感じがして、好感が持てます。
Module1とModule2を（UserForm4のコード以外）、一通り目を通して、好き勝手にコードをいじってみました。 ファイルをアップします。いろんなやり方がありますが、１つの案として参考にしてください。 「シート名：商品マスタ」と「シート名：1（集約元シート）」に、簡単な条件付き書式を設定しています。
http://ww10.puny.jp/uploader/download/1458999886.zip
集約.xlsm（ダウンロードパスワード：abc）
サンプルデータ【2016/03/26(土) 09:26 】の(4)は、B13〜B15に商品コードが入力されており、データ数は3行ですが、 35行（B13〜B47）までデータを追加してください。 行を追加した(4)のシートを複写して12シート作成してください。12シートのシート名は、「1」〜「12」。 以下のコードを使用すると、私のPC環境では、全データを集約シートに書き込む所要時間は、125ミリ秒でした。
************************************************************************************************************* サンプルデータ（集約元シート）を「シート名：集約」（集約先シート）に転記するコード ************************************************************************************************************* Option Explicit Const code_moto As String = "0110" Const code_sizai As String = "0100" Const code_tanto As String = "0900" Declare Function GetTickCount Lib "KERNEL32.DLL" () As Long '◆時間計測（ミリ秒）--- API ---------------
Sub 全シート転記()
Dim StartTime As Long '◆時間計測（ミリ秒）---------------------------------------------------------
Dim msg1 As String, msg2 As String
Dim msg3 As String, msg4 As String
Dim msg5 As String, tmp As String
Dim k As Long, rng As String
Dim MaxRow As Long, ws As Worksheet
Dim Ssh As Worksheet, Srng As Range
Dim n As Long, i As Long, j As Long
ReDim sh_name(1 To 1) As String
ReDim Data(1 To 10, 1 To 1) As Variant
'転記元シートのみ取得し、配列に入れる
For Each ws In ThisWorkbook.Worksheets
Select Case ws.Name
Case "集約": Case "マスタ": Case "商品マスタ"
Case Else
k = k + 1
ReDim Preserve sh_name(1 To k)
sh_name(k) = ws.Name
End Select
Next
'処理開始前の確認
msg1 = " 全店舗のデータを出力します。" & vbCrLf
msg2 = "（転記元のシート数：" & UBound(sh_name) & "）" & vbCrLf & vbCrLf
msg3 = "集約データ出力"
If MsgBox(msg1 & msg2, vbOKCancel + vbInformation, msg3) = vbCancel Then
msg1 = "処理をキャンセルしました。": msg2 = "集約データ出力"
MsgBox msg1, vbOKOnly + vbInformation, msg2: End '終了する
End If
StartTime = GetTickCount '◆時間計測開始（ミリ秒）--------------------------------------------------
Call Automatic_processin_Stop '●●●
'空欄チェック(作業日、商品コード、商品名、数量、温度帯）
For n = 1 To UBound(sh_name)
With Sheets(sh_name(n))
'****************************************
If Trim(.Range("F4").Value) = "" Then
msg2 = "作業日が空欄です。": rng = "F4": k = 0
Call エラー終了(sh_name(n), rng, k, msg2) '●●●
End If
'****************************************
MaxRow = .Cells(Rows.Count, 2).End(xlUp).Row
If MaxRow < 13 Then
msg2 = "商品コードが1つも記入されていません。": rng = "B13": k = 0
Call エラー終了(sh_name(n), rng, k, msg2) '●●●
End If
'****************************************
For i = 13 To MaxRow
If Trim(.Cells(i, 2).Value) = "" Then
msg2 = "商品コードが空欄です。": rng = "B" & i: k = i - 12
Call エラー終了(sh_name(n), rng, k, msg2) '●●●
ElseIf Trim(.Cells(i, 3).Value) = "" Then
msg2 = "商品名が空欄です。": rng = "C" & i & ":F" & i: k = i - 12
Call エラー終了(sh_name(n), rng, k, msg2) '●●●
ElseIf .Cells(i, 7).Value = "" And .Cells(i, 8).Value = "" Then
msg2 = "数量が空欄です。": rng = "G" & i & ":H" & i: k = i - 12
Call エラー終了(sh_name(n), rng, k, msg2) '●●●
ElseIf Trim(.Cells(i, 9).Value) = "" Then
msg2 = "温度帯が空欄です。": rng = "I" & i: k = i - 12
Call エラー終了(sh_name(n), rng, k, msg2) '●●●
End If
Next i
'****************************************
'商品コードが空欄の行に、数量が記入されているものをエラーにするなら
For j = 13 To 47
If Trim(.Cells(j, 2).Value) = "" And _
(.Cells(j, 7).Value <> "" Or .Cells(j, 8).Value <> "") Then
msg2 = "商品コードが空欄の行に、数量が記入されています。"
rng = "G" & j & ":H" & j: k = j - 12
Call エラー終了(sh_name(n), rng, k, msg2) '●●●
End If
Next j
End With
Next n
'並び替え
For n = 1 To UBound(sh_name)
Call 並び替え(sh_name(n)) '●●●
Next n
'集約シートデータクリア
Set Ssh = Sheets("集約")
Set Srng = Intersect(Ssh.Range("A1", Ssh.UsedRange), Ssh.Range("A1", Ssh.UsedRange).Offset(2))
Srng.ClearContents
'転記元からデータを取得して、転記先（集約シート）に書き込み
k = 0 '初期値
For n = 1 To UBound(sh_name)
With Sheets(sh_name(n))
MaxRow = .Cells(Rows.Count, 2).End(xlUp).Row
For i = 13 To MaxRow
k = k + 1
'通常、2次元配列データ Data(k,i) をセルに書き込むとき、
'1次元目（k）は行番号を、2次元目（i）を列番号を表す。
'今回、行番号（k）を動的に変化させたいが、
'ReDim Preserveでは、配列の最後の次元のIndex数しか変更できないため、
'データは、（k）と（i）が逆になった、2次元配列 Data(i,k) に格納していく。
'よって、最後に、Transposeで、2次元配列 Data(i,k) の1次元目と2次元目を入れ替える。
ReDim Preserve Data(1 To 10, 1 To k)
'***********************************************
If i = 13 Then
Data(1, k) = "*" '■A列
ElseIf .Cells(i, 2).Value >= 6000000 And _
.Cells(i, 2).Value <= 6999999 And _
.Cells(i - 1, 2).Value >= 4000000 And _
.Cells(i - 1, 2).Value <= 5999999 Then
'伝票区切り、B列の振替元倉庫コードが変わるごとに「*」を付けるなら
'ElseIf .Cells(i, 2).Value >= 6000000 And _
.Cells(i, 2).Value <= 6999999 And _
.Cells(i - 1, 2).Value >= 4000000 And _
.Cells(i - 1, 2).Value <= 5999999 Or _
.Cells(i - 1, 2).Value >= 6000000 And _
.Cells(i - 1, 2).Value <= 6999999 And _
.Cells(i, 2).Value >= 4000000 And _
.Cells(i, 2).Value <= 5999999 Then
Data(1, k) = "*" '■A列
End If
'***********************************************
If .Cells(i, 2).Value >= 4000000 And _
.Cells(i, 2).Value <= 5999999 Then
Data(2, k) = code_moto '■B列
Else
Data(2, k) = code_sizai '■B列
End If
'***********************************************
Data(3, k) = code_tanto '■C列
Data(4, k) = .Range("C6").Value '■D列
Data(5, k) = code_tanto '■E列
Data(6, k) = .Range("F4").Value '■F列
Select Case .Range("H6").Value
Case "1便": msg1 = "あ 1便"
Case "2便": msg1 = "い 2便"
Case Else: msg1 = "う"
End Select
msg2 = "（納品予定日：" & .Range("I4").Value & "）"
Data(7, k) = msg1 & msg2 '■G列
Data(8, k) = .Cells(i, 2).Value '■H列
'***********************************************
'I列、J列、両方入力されている場合は
If .Cells(i, 7).Value > 0 And .Cells(i, 8).Value > 0 Then
Data(9, k) = .Cells(i, 7).Value '■I列
'++++++++++++++++++++++++++++++++++++++++
'次行を設ける
k = k + 1
ReDim Preserve Data(1 To 10, 1 To k)
For j = 2 To 8
Data(j, k) = Data(j, k - 1)
Next j
Data(10, k) = .Cells(i, 8).Value '■J列
'++++++++++++++++++++++++++++++++++++++++
'I列のみ、入力されている場合は
ElseIf .Cells(i, 7).Value > 0 And .Cells(i, 8).Value = "" Then
Data(9, k) = .Cells(i, 7).Value '■I列
'J列のみ、入力されている場合は
ElseIf .Cells(i, 8).Value > 0 And .Cells(i, 7).Value = "" Then
Data(10, k) = .Cells(i, 8).Value '■J列
End If
Next i
End With
'Application.StatusBar = "処理実行中．．．．(現在 " & n & "件)"
Next n
'「集約シート（転記先シート）：Ssh」における「転記先セル範囲:"A3:J" & k+2」に、
' Transposeで、1次元目と2次元目を入れ替えた配列を代入する。
Ssh.Range("A3:J" & k + 2) = WorksheetFunction.Transpose(Data)
Ssh.Activate
Call Automatic_processin_Restart '●●●
'処理終了後の確認
tmp = (GetTickCount - StartTime) & "[ミリ秒]" '◆時間計測終了（ミリ秒）-------------------------
msg1 = "出力終了しました。" & vbLf
msg2 = "所要時間：" & tmp & vbLf & vbLf
msg3 = "これ以降に数量の修正があった場合は、" & vbLf
msg4 = "修正をお願いします。"
msg5 = "集約データ出力"
MsgBox msg1 & msg2 & msg3 & msg4, vbInformation, msg5
'csv書き出し
msg1 = "このままcsvに書き出ししますか？"
msg2 = "集約データ出力"
'If MsgBox(msg1, vbOKCancel, msg2) = vbOK Then
'Call WRITE_CSVFile '●●●
'End If
Set Ssh = Nothing: Set Srng = Nothing
End Sub
'■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
Private Sub エラー終了(sh As String, rng As String, k As Long, msg2 As String)
Dim msg1 As String, msg3 As String, msg4 As String, msg5 As String
msg1 = "シート「" & sh & "」" & vbLf: msg3 = "エラー終了します。"
Select Case k
Case 0: msg4 = ""
Case Else: msg4 = "(No." & k & ")"
End Select
msg5 = "集約データ出力"
With Sheets(sh)
.Activate
Application.Goto Reference:=.Range("A1"), Scroll:=True
.Range(rng).Select
Call Automatic_processin_Restart '●●●
MsgBox msg1 & msg2 & vbLf & msg3 & msg4, vbCritical, msg5
End '終了する
End With
End Sub
Private Sub 並び替え(sh As String)
With Sheets(sh).Sort
With .SortFields
.Clear
.Add Key:=Range("I13"), _
Order:=xlAscending, _
CustomOrder:="常温,冷蔵,冷凍" '温度帯で並び替え
.Add Key:=Range("B13"), _
Order:=xlAscending '商品コードで並び替え
End With
.SetRange Range("B12:J47")
.Header = xlYes
'.Orientation = xlTopToBottom '並べ替えの方向(上から下)
'.SortMethod = xlPinYin '日本語をふりがなで並べ替えます
.Apply
End With
End Sub
Sub 温度帯で並び替え()
Dim sh As String
sh = ActiveSheet.Name
Call 並び替え(sh)
End Sub
Private Sub Automatic_processin_Stop()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub
Private Sub Automatic_processin_Restart()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With
End Sub
Sub WRITE_CSVFile()
Dim strInitDir As String
Dim f As String
Dim strTitle As String
Dim strFilter As String
Dim strFileName As String
Dim vntFileName As Variant
Dim FSO As New FileSystemObject
Dim TS As TextStream
Dim i As Long
Dim MyLastRow, MyLastColumn As Long
'ダイアログの初期パス（デスクトップ or マクロ実行ブックと同じ階層）
'******************************************************************
'デスクトップ
Dim wsh As Object
Set wsh = CreateObject("WScript.Shell")
ChDir wsh.SpecialFolders("Desktop")
'マクロ実行ブックと同じ階層（ChDrive：マクロ実行ブックが、Cドライブ以外にあるとき必要となる）
'ChDrive ThisWorkbook.Path
'ChDir ThisWorkbook.Path
'******************************************************************
f = Format(Date, "yyyymmdd_") & Format(Time, "hhmmss") & ".csv"
strTitle = "CSVテキストファイル出力処理"
strFilter = "ＣＳＶファイル,*.csv"
vntFileName = Application.GetSaveAsFilename(f, strFilter, Title:=strTitle)
If vntFileName = False Then Exit Sub
strFileName = vntFileName
With ActiveSheet
If .FilterMode Then .ShowAllData
End With
MyLastRow = Range("B" & Rows.Count).End(xlUp).Row
Set TS = FSO.CreateTextFile(FileName:=strFileName, Overwrite:=True)
i = 2
MyLastColumn = Cells(2, 1).End(xlToRight).Column
Do Until i > MyLastRow
TS.WriteLine FP_EDIT_CSVREC(i, 1, MyLastColumn)
i = i + 1
Loop
TS.Close
MsgBox i - 3 & "件作成いたしました。"
Set TS = Nothing: Set FSO = Nothing: Set wsh = Nothing
End Sub
Private Function FP_EDIT_CSVREC(i As Long, STRCOL As Long, ENDCOL As Long) As String
Dim strREC As String
Dim COL As Long
strREC = FP_EDIT_COLUMN(i, STRCOL)
For COL = STRCOL + 1 To ENDCOL
strREC = strREC & "," & FP_EDIT_COLUMN(i, COL)
Next COL
FP_EDIT_CSVREC = strREC
End Function
Private Function FP_EDIT_COLUMN(i As Long, COL As Long) As String
Dim strTEXT As String
strTEXT = Trim(Cells(i, COL).Value)
If IsNumeric(strTEXT) = True Then
FP_EDIT_COLUMN = CStr(CDbl(strTEXT))
Else
FP_EDIT_COLUMN = """" & strTEXT & """"
End If
End Function
（マリオ） 2016/03/26(土) 23:27
●γさま
スマホから見た後に、パソコンで確認したら、全部綺麗に書き直していただけていることを確認しました。
とても見やすくて感動したのと、「Functionってどう使うのか」と調べて、また感動！
こんなことができるのかーーー！！と驚きました。
考え方としてご提示してくださったと思うので、使うには一部書きなおさなければですよね。
途中のfor jの代入の意味がわからなかったのですが、「そうやって使うのか！！！」って
気づけて感動しました。
段々自分のコードに具合が悪くなってきましたが（笑）、書き方を見て
同じように書ける思考を学ばせて頂きます。
かなり時間がかかりそうですが。。。orz
●マリオさま
諸々お手数をお掛け致しまして申し訳ございません。
シートはダウンロードいたしました。ありがとうございます。
頂いても、最終的には自分でメンテできなければ意味がないので、頂いたコードで
しっかり学ばせていただきます。
皆様ご指摘の通り、今のコードですとマスタのシートも並び替えをしてますので、
どのように書いたらいいか悩んでいました。
なるほど、Select Caseで対応できるんですね。。。私はこのコード存在はわかるのですが（笑）
使いこなせていません。（ifとwithがにわかに分かったくらいですからｗ）
また、メッセージも定数にできるんですね！！！
そして処理が早い・・・圧巻です・・。
皆様、私の汚いコードを瞬時に理解して、色々とご提示くださり、
本当に能力の高い方々ばかりで、ここまでしていただき恐縮です。
γさま、マリオさまから頂いたコードを自分の血肉にできるようにします。
心からありがとうございます。
（nyanco） 2016/03/27(日) 12:35
Functionの一番最後で、
＞ws2.Cells(p, 1).Resize(k - 1, 10).Value = mat
＞p = p + k - 1
で、なんで１シート目の終了セルと次のシートの開始セルが重複しないのだろう・・と
デバックしつつ考えていたら、
Resizeさんは、Cells(p, 1)を基点に次が１なんですね!!!
Resizeさん頭いいーーー!!!
配列を一気に代入速いィィィ！！
使いこなせるように頑張ります!!!!
For j = s_motosouko To s_syohinocode
mat(k, j) = mat(k - 1, j)
が、これで動くのもなんでだ、配列覚えてるのか、すごいな・・
信じられんな・・って感じです。。
vbaってすごいですね。
シートレイアウトの件、意味がわかりました。
お察しの通り、私がアップしてたら２日位かかって、きっと
痒い所に手が届く情報は一度ではアップできていなかったと思います。（汗）
マリオさまもすぐ察して頂き、アップしていただいてありがとうございました。。
他ので書き込むことがあれば、コードの件も含め、できるだけ
他の方に分かるようにアップ致します。
次、マリオさまの勉強しますね！
また凄く時間が掛かりそうですが・・。
他の方の投稿もちょこちょこ拝見させていただいておりますが、大変勉強になります。
が、理解が遅いので、理解するまで苦痛を伴っています。（笑）
皆様ほんとにすごいですね・・・。最近この掲示板で感情の起伏が激しくて
体力を消耗します。（大きな感動と、自分の不甲斐なさの落胆にｗ）
これからも少しずつ勉強させて頂きます。。。
（nyanco） 2016/03/27(日) 23:12
To nyanco さん。
＞眠れなくなりました。（爆） ふふふ(^^♪体壊さない程度にがんばってください。
★WorksheetFunctionで取り扱える、配列の要素数は65536個までです。 [[20160327164200]] ←『VBAのワークシート関数について』
2016/03/26(土) 23:27に掲載しているコードでは、 全シート（集約元シート）の情報全てを、配列に入れて、セルへの書き込みを最後に１回行ってますが、 WorksheetFunction.transposeで取り扱える、配列の要素数は65536個までなので、 集約シートへの書き込み最終行が、（65536+2）行を超えたら、正しく表示されません。 計算上、集約元シートが936枚を超える場合、エラーとなる可能性があることになるので、無視していいと思いますが、 65536 ÷ 70 = 936.228… （集約元シートの１シートにつき、フルにデータが格納されていると、集約シートに70行分のデータが書き込まれる。）
★集約元シートのB列（商品コード）に条件付き書式を設定しましたが、次を参考にしてください。 [[20160325224313]] ←『条件付き書式：途中が空欄なら赤く塗りつぶす。』
★集約元シートや商品マスタシートに、余計な、条件付き書式を入力してしまいましたが、 動作が重くなる原因となるので、余計な条件付き書式は、削除した方がいいですね。 集約元シートが30枚を超えたあたりから、挙動が重くなっているなと感じます。
*************************************************************************************************************
★商品マスタ重複チェック() プロシージャ
商品マスタシートのA列（商品コード）に重複がないか、チェックするコードです。
例えば、商品マスタシートのA2=4009830,A3=4009830と、重複させてから、コードを実行してください。
（商品マスタシートSample作成() プロシージャの方は、A314行より、下の行にサンプルを作成します。）
*************************************************************************************************************
Sub 商品マスタ重複チェック()
Dim i As Long, msg1 As String, msg2 As String
Dim mx As Long, sh As Worksheet
Dim flag As Boolean
Call Automatic_processin_Stop '●●●
Set sh = Sheets("商品マスタ")
mx = sh.Range("A" & Rows.Count).End(xlUp).Row
If mx >= 10000 And mx <= 65536 + 1 Then
msg1 = "最終行は、" & mx & "行です。" & vbCrLf
msg2 = "時間が掛りますが、重複チェックを行いますか？"
If MsgBox(msg1 & msg2, vbOKCancel + vbExclamation) = vbCancel Then Exit Sub
ElseIf mx > 65536 + 1 Then
msg1 = "最終行は、" & mx & "行です。（行が多すぎるので、終了します。）" & vbCrLf
msg2 = "（WorksheetFunctionで取り扱える、配列の要素数は65536個までです。）"
MsgBox msg1 & msg2
Exit Sub
End If
msg1 = ""
For i = 2 To mx
If WorksheetFunction.CountIf(Range("A2:A" & mx), Cells(i, 1)) > 1 Then
flag = True
msg1 = msg1 + Cells(i, 1).Address(RowAbsolute:=False, ColumnAbsolute:=False) + " , "
End If
If mx > 10000 Then Application.StatusBar = "処理実行中．．．．(現在 " & i - 1 & "件)"
Next i
If flag = True Then
MsgBox "商品コードに、重複があります。" & vbCrLf & msg1
Else
MsgBox "商品コードに、重複はありません。"
End If
Set sh = Nothing
Call Automatic_processin_Restart '●●●
End Sub
Sub 商品マスタシートSample作成()
Dim sh As Worksheet, rng As Range
Call Automatic_processin_Stop '●●●
Set sh = Sheets("商品マスタ")
Set rng = Intersect(sh.Range("A1", sh.UsedRange), sh.Range("A1", sh.UsedRange).Offset(313))
rng.ClearContents
Range("A314").Value = 314
Range("A315").Value = 315
Range("A314:A315").AutoFill Destination:=Range("A314:A65537"), Type:=xlFillDefault
'Range("A314:A315").AutoFill Destination:=Range("A314:A10001"), Type:=xlFillDefault
Call Automatic_processin_Restart '●●●
End Sub
（マリオ） 2016/03/27(日) 23:30
おっといけない。 （シート名：商品マスタ）は次のようなデータになっています。
|[A] |[B] |[C] |[D] |[E] |[F]
[1]|商品コード|商品名 |項目１|項目２|項目３|項目４
[2]| 4009830|商品名1| | | |冷凍
[3]| 4009831|商品名2| | | |冷蔵
[4]| 4100160|商品名3| | | |常温
[5]| 4100420|商品名4| | | |冷凍
[6]| 4100430|商品名5| | | |冷蔵
[7]| 4100440|商品名6| | | |常温
[8]| 4100450|商品名7| | | |冷凍
（マリオ） 2016/03/27(日) 23:36
今回の件で、ちゃんとコードが書ければ動く事がよくわかりました。
それこそ定数書かなくても・・。(^_^;)
でも今後配列の改変をすることがある（そればっかｗ）なので、
実運用では影響ありそうな場所はある程度定数で書こうと思います。
＞ ★集約元シートのB列（商品コード）に条件付き書式を設定しましたが
ををを！
今気付きました。ありがとうございます。
確認して使えるところは是非使わせて（学ばせて）いただきます。
だから掲示板で色々と質問してくださっていたのですね！！！( TДT)
なっ、なんてことを！！！！
惚れてまうやろｗｗ
っていうかこれタダでアップしちゃっていいのでしょうか・・・・
お金払っても欲しい人いると思いますが・・
とにかく、せっかく教えていただいたのですから同じようなことを何度も聞かないように
しっかり学んでいきます。
本当にありがとうございます。
（nyanco） 2016/03/27(日) 23:57
To nyanco さん
こちらも、新しい発見があるから、やってるんですよ〜 （つまらないテーマのときは、関わりません）
実験的に、1シートごと配列に入れて、集約シートに書き込むコードも、書いてみたいと思います。 集約シートに７万行書き込めるかどうか、試したい。集約元シートを1000枚用意して(^^♪
集約シートへの書き込み最終行が、（65536+2）行を超えるぐらい、データを多く書き込みたいときは、 全シート（集約元シート）の情報全てではなく、■１シートごとの情報を配列に入れて、 １シートごとに、集約シート（集約先シート）に書き込む。次のシートの情報を配列に格納する前に、 配列の内容を■Eraseを使って、初期化する。 そのようにすれば、配列の要素数が65536個を越えることはないと思います。
配列の初期化（Erase について） https://www.moug.net/tech/acvba/0050008.html （マリオ） 2016/03/28(月) 00:14
おはようございます。
テーマとは関係のない、あさってのコメントです。
msg2 = "（WorksheetFunctionで取り扱える、配列の要素数は65536個までです。）"
ワークシート関数は、星の数ほどあります。 で、もちろん、そこで扱う配列の要素数が65536個以上でもＯＫの関数もたくさんあります。 （というか、TRANSPOSE等は、むしろ例外？）
ここはメッセージ内容を、誤解のないものにしておかれたらいいですね。
（β） 2016/03/28(月) 07:15
To マリオさん
雑談程度に。
・マリオさんの好み？か、配列を1行ずつ Redim Preserve で増やしていくコードが多いですね。 もちろん、ダメではないのですが、シート毎に必要行数（Preserve機能を使うために配列としては列数）を与えて拡張してやれば 行ごとのRedimは不要になります。そうすることで、対象外で配列に格納しない行のスペースもふえてしまいますが、 結果的に、シート毎につもりつもった余分な未使用行（列）が配列の最後にからっぽで残ったとしても、無視すればいいわけです。
・なぜ、Redimが必要になるか。配列規定する際に最大要素数が把握できないからですね。
↑でもふれましたが、多めに要素数を指定しておき、余った分は使わないという、乱暴なやりかたもあります。 極端にいえば、ReDim w(1 To 10, 1 To Rows.Count) とか。 さすがに、ReDim w(1 To 1000, 1 To Rows.Count) なんてやると、メモリー不足エラーで Redim の瞬間にエラーになりますが。
・なぜ、TRANSPOSE が必要になるか。要素数を増加させていきたい、それは列方向にしか増やせない。だから 縦横逆の配列にして、最後にひっくり返す。
これは、いろんな方法があると思いますよ。65536 の制限のために、あれこれチェックしてそれを制御するロジックを盛り込むのも悪くはないですが 制御のための制御ロジックになって、肝心のアプリロジックが見えにくくなる、全体として煩雑でわかりにくいコードになるかも。
１）さきに書きましたが ReDim w(1 To Rows.Count,1 To 10) と、最初から【まっとうな2次元配列】にしておけば、まったく気にする必要はなくなります。 もし、実際の行数が Rows.Countを超えてしまったらどうするんだ！ でも、その場合、そもそもが、結果をシートに落とし込めませんね。Rows.Count がマックスですから。 ２）最初に各シートをループ参照して、そこで必要な行数を足し算で求める。で、一括して Redim w(1 To 必要行数,1 To 100) と、【まっとうな2次元配列】を準備する。 シートが何百枚あろうと、一瞬です。
３）1次元の親配列を用意する。要素数は、対象シート数。 で、シート毎に、【まっとうな2次元配列】を作って処理し、その2次元配列を 親配列に格納。 最後に転記する時点では、この親配列から要素（シート毎の2次元配列）を取り出して書きこみ処理を行う。 シート転記が1回ではなく、シート数の転記になりますが、100枚あっても、たかだか100回の書き込みです。 （遊び心で、この親配列をDictionaryやArrayListやCollection といった、動的に要素を追加していける媒体にしてもいいですが）
（β） 2016/03/28(月) 08:30
To β さん
＞TRANSPOSE等は、むしろ例外？
[[20160327164200]] のtest4,test5も参照してください。
VBAのWorksheetFunctionでは、★Transpose , ★Sum ,★Max ,★Minの４つに関しては、 配列の要素数の制限（65536）があることが分かりました。
msg2 = "（WorksheetFunctionで取り扱える、配列の要素数は65536個までです。）" と書きましたが、★4つのWorksheetFunctionしか検証していません（汗）。
----------------------------------------------------------------------------------------- ＞多めに要素数を指定しておき、余った分は使わないという、乱暴なやりかたもあります。 たしかに、βさんのいうところの下記B案の方がいいかも(^^♪transposeを使わずに、配列をセルに書き込む。
2016/03/26(土) 23:27に掲載しているコードですが、無理して、transposeを使っている感じですね（汗）。 なんで、そこまでして、transpose使いたいのって！突っ込みたくなりますね(^^♪
余談ですが、ファミコンソフト「マリオブラザーズ」のゲームまるごとの容量は、たったの40KBです。 http://labaq.com/archives/51861918.html こんな記事を見ると、メモリをできるだけ使わないようにしたくなります(^^♪
PCのメモリをできるだけ使わないようコーディングしていくと、Redim Preserve と transoposeを使うことになりますよね…。
A案（2016/03/26(土) 23:27に掲載しているコード） ***************************************************************************************** ReDim Preserve Data(1 To 10, 1 To k) 'kは動的変数 【書き込みたいセル】 = WorksheetFunction.Transpose(Data)
■transposeで、1次元目と2次元目をひっくり返す。 *****************************************************************************************
B案 ***************************************************************************************** ReDim Data(1 To 10, 1 To Rows.Count) 'ReDimで動的変数を使わない。 【書き込みたいセル】 = Data 'transposeも使わなくて済む。
■Rows.Countの値は、xlsmファイルなら、1048576の固定値、xlsファイルなら、65536の固定値 ■多めに配列の箱を事前に用意する。この程度なら、メモリを使いすぎという程でもない。 *****************************************************************************************
----------------------------------------------------------------------------------------- ＞シート毎に、【まっとうな2次元配列】を作って処理し、その2次元配列を 親配列に格納。
シート毎に処理するなら、僕なら、 シート毎のデータの格納→セルへの書き込み→（配列をEraseして初期化） →シート毎のデータの格納→セルへの書き込み→…】と交互に処理します。 （ただし、セルへの書き込みは、書き込み先シートの最終行の次行から） （マリオ） 2016/03/28(月) 13:01
>PCのメモリをできるだけ使わないようコーディングしていくと、Redim Preserve と transoposeを使うことになりますよね…。
Redim Preserve は、使わないで済む工夫をすれば、使う必要はないですし、 Transpose を使うために、配列の行数制御で、面倒な仕組みをコード内にちりばめるということであれば それこそ、本末転倒ですねぇ。行数制御をしなくてもいいなら、ちょっと、どっこらしょという感じで重い処理ですがTranspose もＯＫ． でも行数制御をするなら、逆に Transpose をかけなくてもいい工夫をすることが先決では？
>>こんな記事を見ると、メモリをできるだけ使わないようにしたくなります(^^♪
たしかに、ゲームソフトはすごいですよね。ただ、（今はずいぶん構造も変わったと思いますけど）制御系ソフトは そもそもが、それが稼働するハードというか、メモリーも含めたものが、極小で、そのなかで、ゲーム上のアクションを 遅れることなくキャッチしていかなければいけないんですよね。 なので、もう、メモリーを切り詰めることを至上テーマとして、がんばっているんだと思います。
（余談の余談ですが、大昔、メモリー16K、しかも仮想記憶なしという、いわゆる【電子計算機】でアセンブラープログラムを書いていたころは それこそ、なんとかして１バイトでも２バイトでも切り詰められないかと、判定フラッグなんかも １バイトなんていう贅沢なことはできず ビット単位で処理してました）
ただ、昨今の環境、とくに【エクセル】を考えた場合、どうでしょうかね。 何もしなくても、たとえば、17,179,869,184個のセルの値を格納する場所や、それぞれのセルをウォッチするイベント監視機能含め 裏で、うじゃうじゃ動き、当然メモリー領域も使っています。
そういった尺度で考えると、1000行ぐらいなんぼのもんじゃ という気持ちになりませんか。 そこで、１行、配列の確保スペースを節約できたといっても、海辺の砂浜の砂が1粒へったぐらいなもの？
まぁ、本トピのテーマなら、βであれば、最初にシートを空読み、それぞれの最大行数を加算しておいて その値を行数にして Redim で、「まっとうな2次元配列」を作りますね。
（β） 2016/03/28(月) 14:11
To βさん ＞多めに要素数を指定しておき、余った分は使わないという、乱暴なやりかたもあります。 ＞ReDim w(1 To Rows.Count,1 To 10) と、最初から【まっとうな2次元配列】にしておけば、
恐縮です。すいませんm(_ _)m
test1だと、「実行時エラー 7 メモリが不足しています。」となってエラー終了しちゃいました。
Sub test1()
ReDim Data(1 To Rows.Count, 1 To 10) As Variant'●Varinat型
End Sub
下記の「配列上限取得計算マクロ」で、私のパソコンの環境下で、配列の上限を調べたら、 Variant型配列で400万個まで、String型配列で1100万個まで配列を作成できるみたいです（★の型を変更して実行）。 つまり、その個数を越えたらメモリが不足して、エラー終了します。 （コードを実行するたびに、個数の結果が異なる。また、100万個単位で調べました。）
String型配列の上限が私のパソコンの環境下では、1100万個だったので、 ReDim w(1 To Rows.Count,1 To 10) As String'●String型 だと、ぎりぎり、プログラムが動きます。 （列数が10で、行数がRows.Count(xlsmファイルなら、1048576=約100万)であるから、 約1000万個の配列なので）
10列であることは、確定なので、多めの要素数をはじめに指定するとしたら、 ReDim Data(1 To 100000, 1 To 10) As Variant ぐらいが安全かな〜って思うのですが。
***********************************************************
Sub 配列上限取得計算()
On Error GoTo ErrEnd
Const kankaku As Long = 1000000 '100万単位で調べる
Dim i As Long, Moji As String
ReDim ans(1 To kankaku) As Variant '★
Moji = "01,02,03,04"
i = 1
Do
If i Mod kankaku = 0 Then
ReDim Preserve ans(1 To i + kankaku) As Variant '★
End If
ans(i) = Moji
i = i + 1
Loop
Erase ans: Exit Sub
ErrEnd:
MsgBox Err.Description & vbCrLf & _
"これ以上の配列を設定できません。" & vbCrLf & _
"上限は" & i & "です。"
Erase ans: Err.Clear
End Sub
------------------------------------------------- パソコンの環境 Windows8.1(OSは、64bit) 実装メモリ（RAM）は、8.00GB ★Excel2013（OSが64bitでも32bitのアプリとして動く。） （プロセッサ：Intel Core 7MQ CPU 2.40GHz) ------------------------------------------------- http://oshiete.goo.ne.jp/qa/8517809.html ← 参照 （マリオ） 2016/03/28(月) 21:43
To マリオさん
とんだことで時間をとらせたみたいで恐縮。
Rows.Count は、ぎょくたんな例としてあげたもので、実際に、自分で、これを使ってコードを書こうとは思いません。 当方のＰＣではコメントしたように、1 To Rows.Count,1 To 10 はＯＫ，でも 1 To Rows.Count,1 To 1000 だとＮＧです。
いいたかったことは、たとえば、自分自身が今まで書いたコードで配列の行数を、面倒な計算式を使って 掛け算したり割り算したり、割り算の結果で余りが出たら、１行増やす、余りがなかったら、結果そのままで 配列の要素数としてRedim なんてことをやっていたんですが、これって、ばかげていたなぁと反省もこめて 適当に大きくとっておけばいいじゃないかというぐらいの意味でした。
>>ReDim Data(1 To 100000, 1 To 10) As Variant >>ぐらいが安全かな〜って思うのですが。
同感ですね。その要件にもよりますが、最大でも100000 件 といったように、マックス値を限定して処理する仕様は、 現実のプログラムでも一般に取り入れられている方式です。
ただ、しつこいようですが、本トピのテーマであれば、配列に必要な（というより充分な）行数は 最初からわかるわけですから、その行数で最初に１回、通常の２次元配列として設定。 格納ごとの Redim も 最後のTransposeも不要だと思いますね。
（β） 2016/03/28(月) 22:01
●マリオさま
コード、凄く速く動いています。サーバ越しでも大丈夫です。
少し現場用に書き直しましたが、気になった点のみお知らせしますね。
１）空欄チェック（商品コード、商品名、数量、温度帯）は動いていなかったので、
こちらがほしい条件に直して動かしました。
２）「'J列のみ、入力されている場合は」の部分、単純に書き間違いかと
思いますので、上記のコードも修正しますね。
ElseIf .Cells(i, 8).Value > 0 And .Cells(i, 7).Value = "" Then Data(10, k) = .Cells(i, 7).Value '■J列 ←ここが8ですね。
３）他のブックに転記したコードで、「集約シートをクリアする時」エラーが出ます。
'集約シートデータクリア
Set Ssh = Sheets("集約")
Set Srng = Intersect(Ssh.Range("A1", Ssh.UsedRange), Ssh.Range("A1", Ssh.UsedRange).Offset(2))
Srng.ClearContents ←ここでエラー
他のブックは基本的に最初は集約シートにデータが入っていないので、
エラーになるのかなと思いますが、マリオさまから頂いたファイルは、データが入っていない
状態からスタートしてもエラーになりません。
コードの差分チェックツールで間違いがないかチェックしましたが、
見当たらず。謎です。
運用ではifでデータがある時だけクリアするようにしています。
本当に、沢山書いて頂いて、日々勉強になっています。
大感謝です。ありがとうございます。
「ああっ！これやりたかったのこれ！！！」っていうのもあって
書き方が分かって活用しております。
もっと勉強して応用できるようになりたいです。
γさまとマリオさまに頂いたコードをミックスして違う所で活用させていただきました！
代入って便利・・・
しかしながら、まだ基本的なプログラムのロジックというかアルゴリズムというのか、
を理解していない部分が私にあるのでしょう。
別件のとってもくだらないところで、躓いています。。。。。
（くだらないと分かっていても答えが出ない無能さ・・orz）
もう少し考えてわからなかったらきっとトピック上げます。（涙）
また、今後もコードを書くことがありますので、質問させていただきますね。
みなさま、今後共よろしくお願いいたします。
（nyanco） 2016/03/30(水) 20:36
To nyanco さん
＞コード、凄く速く動いています。サーバ越しでも大丈夫です。 よかったですね(^^♪
>(1) あれれ、機能しませんか。ちゃんと、検証してなかったしな〜。 どこがいけなかったんだろ?
コードを載せて、もう少し詳しく教えてくれませんか？ ほしい条件を、教えてくださ〜い。
>(2)(3) Just a moment…コード見直します。
(3)のIntersectはUsedRangeにデータがないとエラーになっちゃうのかな。 Debug.Print 【セル範囲】.Address で検証してみれば、謎がとけると思いますが。
>運用ではifでデータがある時だけクリアするようにしています。 どう、エラー処理しましたか？
（マリオ） 2016/03/31(木) 11:08
To nyanco さん
セル範囲に配列を代入するロジックは、もう十分理解されたと思いますが、 念のため、もう一度。 2016/03/24(木) 21:52 にも載せましたが、基本的なロジックはtest3,tes4です。 ★2次元配列の1次元目がセルの行に対応、2次元配列の2次元目がセルの列に対応 これが基本です。
Sub test3()
Dim z As Long
z = 3
ReDim x(1 To z, 1 To 2) As String
x(1, 1) = "あ"
x(1, 2) = "い"
x(2, 1) = "か"
x(2, 2) = "き"
x(3, 1) = "さ"
x(3, 2) = "し"
Sheets("Sheet1").Range("A1:B3") = x'★書き込みたいセル範囲（A1:B3）
End Sub
******************************
|[A] |[B]
[1]|x(1,1)|x(2,1)
[2]|x(1,2)|x(2,2)
[3]|x(1,3)|x(2,3)
***************************************************************************
Sub test4()
Dim z As Long
z = 3
ReDim x(1 To z, 1 To 2) As String
x(1, 1) = "りんご"
x(1, 2) = "ゴリラ"
x(2, 1) = "らっぱ"
x(2, 2) = "パセリ"
x(3, 1) = "リーチ"
x(3, 2) = "チョンボ"
Sheets("Sheet1").Range("G5:H7") = x '★書き込みたいセル範囲（G5:H7）
End Sub
******************************
|[G] |[H]
[5]|x(1,1)|x(2,1)
[6]|x(1,2)|x(2,2)
[7]|x(1,3)|x(2,3)
（マリオ） 2016/03/31(木) 12:10
１）空欄チェック（商品コード、商品名、数量、温度帯）
私用にカスタマイズしてください、ということかと認識しておりましたので、
細かく書かずに失礼しました。
以下のチェック部分は、Trimでくくってあり、スルーになっておりました。
私には原因がわからなかったので、とりあえずTrimを外して、
ほしい条件「商品コードが入っていて名前が空欄」と「商品コードが入っていて温度帯が空欄」
の条件を追加しました。
「商品名が入っていて数量が空欄」の場合は、私の間違えで無視されます。（今気付きました）
（maxRow = .Cells(Rows.Count, 2).End(xlUp).Row）
で、商品コード（２）のある場合を見てるので。
でも、商品コードが入っていない場合は、この時には必要ないので（スキップ）まぁいいかなと思ってます。
'****************************************
For i = 13 To maxRow
If .Cells(i, 2).Value > 0 And .Cells(i, 3).Value = "" Then
msg2 = "商品名が空欄です。": rng = "C" & i: k = i - 12
Call エラー終了(sh_name(n), rng, k, msg2) '商品コードが入っていて名前が空欄
'ElseIf Trim(.Cells(i, 3).Value) = "" Then
' msg2 = "商品名が空欄です。": rng = "C" & i & ":F" & i: k = i - 12
' Call エラー終了(sh_name(n), rng, k, msg2) '●●●
ElseIf .Cells(i, 2).Value > 0 And .Cells(i, 7).Value = "" And .Cells(i, 8).Value = "" Then
msg2 = "数量が空欄です。": rng = "G" & i & ":H" & i: k = i - 12
Call エラー終了(sh_name(n), rng, k, msg2) '商品名が入っていて数量が空欄
ElseIf .Cells(i, 2).Value > 0 And .Cells(i, 9).Value = "" Then
msg2 = "温度帯が空欄です。": rng = "I" & i: k = i - 12
Call エラー終了(sh_name(n), rng, k, msg2) '商品コードが入っていて温度帯が空欄
End If
Next i
'****************************************
３）クリアのエラー
まだデバックしていませんが、先に書き込みを。
マリオさんのブックではエラーにならないので、私の勘違いなのかなーと思っていました。
よって、単純に、
Set Srng = Intersect(Ssh.Range("A1", Ssh.UsedRange), Ssh.Range("A1", Ssh.UsedRange).Offset(2))
If Ssh.Range("B3") <> 0 Then
Srng.ClearContents
End If
と書きなおしています。掲示板も直した方がいいでしょうか。。
４）単純な所で躓いた話
無用なご心配をお掛けしてすみません。（滝汗）
全然違う話で、結局自己解決しました。書くのもハズカシイことですが・・・
==条件=======
「テスト」というシートがあれば、その情報を更新する。
無ければ、新たにシートを作成する。
=========
という条件で、一生懸命「「テスト」出せやゴラァ」ばりの無茶なコードを書いて
エラーになっていました。
考え方としては、
「ブックの中の全てのシートの中から、「テスト」というシートが存在するか確認して、
あったら処理をする。無かった時は別の処理をする」
という処理じゃないとダメなんですね！！！！と気付きました。（恥）
【「テスト」というシートがあったら】をどうコードで書いていいのかわからなくて、
暫く悩みましたという話です。くだらなくてすみません。(T_T)
結局以下のように書きました。
For Each ws In Worksheets
If ws.Name = "テスト" Then flag = True
Next ws
If flag = True Then 処理
Else
違う処理
End If
日々、同じようなことで悩んでいます。（苦笑
（nyanco） 2016/03/31(木) 20:44
データクリアした状態で、転記を実行
Set Srng = Intersect(Ssh.Range("A1", Ssh.UsedRange), Ssh.Range("A1", Ssh.UsedRange).Offset(2))
Debug.Print Range(Cells(3, 1), Cells(10, 100)).Address '★
Srng.ClearContents
マリオさまのファイル→エラーなし
にゃんこのファイル→エラーでストップ
デバックしたら、マリオさまからいただいたファイルも
自分のファイルも同じ結果になりました。
$A$3:$CV$10
です。（なんでこの範囲なんだろうというのもありますけど）
まぁでもIf処理すればいいだけかと思いますので使用には問題ないのですが、なぞですね。。
（nyanco） 2016/03/31(木) 21:08
To nyanco さん
1)について。
なぜ、Trimを使っているかについて。 例えば、温度帯が入力されている「I14」セルを削除（数式を削除）してから、 「I14」セルに「半角スペース」を1つ入力してください。 画面表示を見ると、「I14」セルは、【空欄ではないけれど空欄に見えますよね！】 「半角スペース」が入力されているので「=""」（空欄）ではなく、「="■"」です。（※■は半角スペースを表現）」
「半角スペース」が入力されちゃうなんてことは、 なさそうな事なんで、コードのTrimを外しても大した問題にはならないとは思いますが。 ************************************
下記のコードは、提供したコードです。
*******************************************************************************************
For i = 13 To MaxRow
If Trim(.Cells(i, 2).Value) = "" Then
msg2 = "商品コードが空欄です。": rng = "B" & i: k = i - 12
Call エラー終了(sh_name(n), rng, k, msg2) '●●●
ElseIf Trim(.Cells(i, 3).Value) = "" Then
msg2 = "商品名が空欄です。": rng = "C" & i & ":F" & i: k = i - 12
Call エラー終了(sh_name(n), rng, k, msg2) '●●●
ElseIf .Cells(i, 7).Value = "" And .Cells(i, 8).Value = "" Then
msg2 = "数量が空欄です。": rng = "G" & i & ":H" & i: k = i - 12
Call エラー終了(sh_name(n), rng, k, msg2) '●●●
ElseIf Trim(.Cells(i, 9).Value) = "" Then
msg2 = "温度帯が空欄です。": rng = "I" & i: k = i - 12
Call エラー終了(sh_name(n), rng, k, msg2) '●●●
End If
Next i
*******************************************************************************************
B13,B15,B16と商品コードが入力されている場合、 B16が商品コードの最終行とされます。つまり上のコードで、maxRowが16になります。 提供したコードには、条件が４つありますが、１つ目の条件は、 B14が空欄であることを見つけるためのコードです。
３つ目の条件では、Trimを使ってません。なぜなら、 ケースとバラの項目であるG列、H列には、【データの入力規則】が設定されており、 整数（0〜99999)の設定と「空白を無視するにチェック」の設定がされているため、 「=""」はありえるが、「="■"」（※■は半角スペースを表現）はありえないからです。
話を変えますが、【データの入力規則】、B列の商品コードにも設定してもいいかもしれません。 整数（1000000〜9999999）の設定と「空白を無視するにチェック」の設定で！ こうすれば、B列の商品コードは、【空白】または、【7桁の整数】以外のデータは入力できません。
1〜MaxRowまで、商品コードが入力されていることを先にチェックしているので、 商品コード欄が0以上の数値であるならを意味する「.Cells(i, 2).Value > 0」の条件は、 なくてもいいと思います。
商品コードの最終行が、B20だとすると、MaxRowは20になります。 仮に、C21,I21は数式が消されてなければ空欄です。 また、C21,I21の数式が消されて「何かしらの文字列」が入力された場合、 上のコードでは、21行目はチェックされません（MaxRowが20なので）。 C列、I列の数式が消されないように、シートにパスワード保護をかけてもいいかもしれません。 （コードを実行するときは、マクロでパスワード保護を一時的に解除する。） ********************************************
下のコードは必要ですよね。
maxRowが仮に30のときに、
31〜47行に、商品コードが空欄で、数量が入力されているところがあったら、
エラーにしないと集計されちゃいますからね。
*****************************************************************************
'商品コードが空欄の行に、数量が記入されているものをエラーにするなら
For j = 13 To 47
If Trim(.Cells(j, 2).Value) = "" And _
(.Cells(j, 7).Value <> "" Or .Cells(j, 8).Value <> "") Then
msg2 = "商品コードが空欄の行に、数量が記入されています。"
rng = "G" & j & ":H" & j: k = j - 12
Call エラー終了(sh_name(n), rng, k, msg2) '●●●
End If
Next j
*******************************************************************************************
（マリオ） 2016/04/03(日) 07:20
２）わぉ(#^^#)恥ずかしや〜、単純な書き間違いです。
コード内で、「'J列のみ、入力されている場合は」とあるところの2行下、 .Cells(i, 7).Value → .Cells(i, 8).Valueですね。
３）こうエラー処理してください。
Set Srng = Intersect(Ssh.Range("A1", Ssh.UsedRange), Ssh.Range("A1", Ssh.UsedRange).Offset(2))
'Debug.Print Srng.Address
If Not (Srng Is Nothing) Then Srng.ClearContents
****************************************************************************************************
なお、
>Debug.Print 【セル範囲】.Address
>で検証してみれば、謎がとけると思いますが。
と書きましたが、
Debug.Print Srng.Address
を記述して、検証してほしかったんです。セル内の値を手作業で消去しても、Debug.Printでセル範囲が返ってくるときは、
そのセル範囲の行を全て削除（行の削除）してから、Sub ■集約シートデータクリア()マクロを実行すると、
エラーになります。
Set Srng = Intersect(Ssh.Range("A1", Ssh.UsedRange), Ssh.Range("A1", Ssh.UsedRange).Offset(2))
でセル範囲がSrngに帰ってこないと、SrngにNothingが返ってきます。
エラーになってデバックすると、Srngにマウスカーソルをもっていくと、Nothingと表示されます。
４）同じように、悩んだ時期があります。１年ほど前です(#^^#) （マリオ） 2016/04/03(日) 08:04
To nyanco さん
ちなみに、 ４） ＞For Each ws In Worksheets ですが、次のようにした方がいいかもです。 上記だと、ブックが複数開いているときに、別ブックのシートも探してしまいます。
******************************************************************************************
For Each ws In ThisWorkbook.Worksheets'マクロを実行しているブックのシートのみ探す。
******************************************************************************************
For Each ws In Workbooks("■■.xlsx").Worksheets'「■■.xlsxブック」のシートのみ探す。
（マリオ） 2016/04/03(日) 21:10
失礼します。
TO マリオさん
>>上記だと、ブックが複数開いているときに、別ブックのシートも探してしまいます。
複数ブックが開かれている状況では、どのブックのシートかを、しっかりと ブック修飾することは 必要なことですね。
ただ、表現として使われた 『別ブックのシート【も】探してしまいます。』
あくまで、このコードは「単一ブック」のシートのみを抽出します。あのブックからも、このブックからも シートを抽出するわけではありません。
『別ブックのシート【を】探してしまう【ケースもあります】』 でしょうね。
マリオさんは、もちろん。理解しておられ、たまたま、ミスタイプ だとは思いますが、質問者さんが勘違いされる心配があったので 老婆心ながらコメントしました。
（β） 2016/04/03(日) 21:21
To βさん
>あくまで、このコードは「単一ブック」のシートのみを抽出します。 そうかな〜とも思ったのですが、勘違いしてました。
nyanco さん！、β先生のおっしゃるとおり、 『別ブックのシート【を】探してしまう【ケースもあります】』ですよ。
要するに、For Each ws In Worksheets は、 For Each ws In AcviveWorkbook.Worksheets と同じ意味なんですかね〜。 （マリオ） 2016/04/03(日) 21:34
それにしても、他の質問でもコードを書くのが速いですね。
思わず、すごい〜！！なんて余計な書き込みをしそうになります。
マリオ様は1年ですごい成長をしたのですね。すごすぎる。。
（nyanco） 2016/04/04(月) 21:23
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.