[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『5行おきに別ブックから数字を転記』（にゃん）
すみませんＢＶＡ初心者です。
★実績表と×月実績表という二つのエクセルがあります。
★はブックの名前についてるもので×は実際の月が入り毎月新しく作られるブックです。
★実績表に
A1 担当者名
A B C D E F G〜 L M〜 S
種類 番号 品目名 タイトル 目標 4月 5月〜 上期計 10月〜 下期計
という表が4行目から5列おきに項目が出ます。
C列の品目別に入っている金額をF列以降の該当月の次の行に転記したいのですが
(4月であればC4の検索結果をF5に転記)
実績表は
A B C D E〜 K〜 Q〜 X〜
受信日 発注日 期 年 月〜 品目別〜 担当者名 金額
となっており★実績表のA1から品目別のQ列担当者を絞り、その後品目別で絞ってX列の金額の合計をF列以降の該当月の次の行に入れたいのですが同じ作業のシートが5枚あります。
また、★実績表のB列の番号は4行目から5行おきに番号がありますがある一定のところで番号が飛び、5番おきになります(現状通番は15まで、その後40,45,50)
40番以降のは3品目づつの合算が二つ、50番はその他の合計を記載しなければならずあれこれ調べてますが5行おきのコード検索から躓いてる状態です。
品目別の表では最終的に担当者ごと、品目別でピポットを組んでますので先にピポットを作ってそこから持ってこようかとも思ったのですが思考がまとまらず、どなたか知恵をお貸し願います。
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
こんにちは ＾＾ 。。。 気が付いた点だけ。。。 ＞という表が4行目から5列おきに項目が出ます。 とは？五列は空白ですか。 ＞C列の品目別に入っている金額 Ｃ列は品目では？、金額は何処に？ ＞同じ作業のシートが5枚あります。 とは、内容、シート名、BOOK名が不明？ ＞40番以降のは3品目づつの合算が二つ、50番はその他の合計 3品目とは、その他は何を指すのですか。 後、結合セルが有りそぉなきがするのですが。有れば、その内訳 等々が 分かりにくいような気がするのですが。。。（私だけかも）＾＾； もう少し具体的に説明されると回答が付きやすいかもですよ。
＞５行おきのコード検索から躓いてる 他のセルが空白なら［スペシャルセルズ］などで調べるといいかもです。 （隠居じーさん） 2018/05/18(金) 11:06
＞C列の品目別に入っている金額 Ｃ列は品目では？、金額は何処に？
すみません本当はもっと長い文字が入ってますが中身は品目名が記載されてるだけなのでここでは品目でお願いします。
金額はX列です。わかりにくくてすみません。
＞同じ作業のシートが5枚あります。 とは、内容、シート名、BOOK名が不明？
内容は★実績表の上記の表が全部で6シートあり、1シート目は全部の合計が入るようになっており、2〜6シート目に担当ごとに分かれて入力する状態です。シート名は担当者の名字が入ってます。
これが★実績表のブックに入ってます。
＞40番以降のは3品目づつの合算が二つ、50番はその他の合計 3品目とは、その他は何を指すのですか。
40番以降は品目名が複数あり、その合計です。抽出しにくいので現在、×月実績表のAR列に新たに
40番の項目(3品目)をその他1、45番(3品目)をその他2、50番(1〜45までに記載のなかった品目。30以上あり、今後も増えます)をその他3で作り直してます。
それ以外はK列の品目別を入れてるのでK列ではなくAR列で絞ってからX列の合計を出した方がいいのかと思ってます。
わかりにくくて申し訳ございません。ご教授いただけると助かります。
スペシャルセイズ、確認してみます。
（にゃん） 2018/05/18(金) 11:29
A B C D E F G H I J J K L M N O P Q R
1 浅野裕子
2
3
4 種類 番号 品目名 タイトル 目標 4 月 5 月 6 月 7 月 8 月 9 月 上半期 10 月 11 月 12 月 1 月 2 月 3 月 下半期
5 食品 1 うどん 計画 世界一 1347 338 164 1294 1231 1340 5714 871 996 1040 1380 557 649 5493
6 実績 アメリカ
7 計画 日本一
8 実績 アフリカ
9 計画 地元
10 実績 無し
11 食品 2 そば 計画 世界一 795 1241 1440 1240 533 648 5897 888 619 770 409 256 1430 4372
12 実績 アメリカ
13 計画 日本一
14 実績 アフリカ
15 計画 地元
16 実績 無し
137 食品 50 やまかけ 計画 世界一 547 840 354 1463 752 541 4497 942 992 636 935 1010 160 4675
138 鍋焼き 実績 アメリカ 418 280 49 251 368 146 1512 757 641 336 689 932 320 3675
139 かけ 計画 日本一 94 1023 1122 107 373 96 2815 935 1446 270 1274 5 1392 5322
140 実績 アフリカ
141 計画 地元
142 実績 無し
★実績表、浅野シート、想像図 ＾＾ 外していましたらご修正を （隠居じーさん） 2018/05/18(金) 15:14
（にゃん） 2018/05/18(金) 15:32
A B C D E F G H I J K L M N O P Q R S T U V W X
1 受信日 発注日 期 年 月 品目 品目 品目 品目 品目 品目 品目 品目 品目 品目 品目 担当者 ？ ？ ？ ？ ？ ？ 金額
2 2018/4/10 2018/5/10 やまかけ 鍋焼き かけ 浅野裕子 1000
3 2018/4/11 2018/5/10 うどん 浅野裕子 500
4 2018/4/12 2018/5/10 そば 浅野裕子 600
5 2018/4/13 2018/5/11 卵丼 大飯食 700
✖月実績表 は情報が少ないため 外している可能性が大です。 訂正後、情報の共有が出来ましたら。何かアドバイスくらいはできるかなぁ？ と思っています、また他の方が回答して下さるかもしれません。＾＾； （隠居じーさん） 2018/05/18(金) 19:09
あ。。。すみません 金額の整合性がとれていません。 浅野裕子さんの やまかけ 鍋焼き かけ＝ 1059 うどん ＝ 1347 そば ＝ 795 ですかね。 すみません。 （隠居じーさん） 2018/05/18(金) 19:21
もう一つ確認ですが番号は品目に対応しているのでしょうか品目番号？ ただの通し番号？ ｘ実績表の方には番号表示は無いのでしょうか。＾＾； （隠居じーさん） 2018/05/18(金) 20:29
その上で勘所がわるくて表イメージがつかめてないのですが、
・コピー元のセル範囲が特定できないのか
・貼付先のセル範囲が特定できないのか
・どちらも特定できないのか
どれなんでしょうか
または、
品目１に記載されてるデータをオートフィルタで４月分を抽出して
集計表の品目１の４月の部分に貼付
みたいなうごきはどうでしょうか
（もこな２） 2018/05/19(土) 11:17
すみません。テンパっていろいろ間違ってます。書き方が悪くて申し訳ございません。
やらなければいけないのがA1セルに入っている担当者からＸ月実績表の担当者(Q列)と該当項目(Ｃ４から５行おき)でさらに絞って該当月(Ｆ列以降)に合計を入れる形ですが同じ作業が担当者ごとにあり、シートは６シートあります。(１シート目は全担当の合計なので２シート目から)
★実績表を開ける際に該当月の×月実績表を開けるようにしたのですがそこで入れた数字からひっぱてこれないか考え中です。
★実績表を開いた際のコードが
Private Sub Workbook_Open()
' Sub 処理月入力()
Dim tuki As String
tuki = InputBox("処理月を入力してください", "半角数字")
If tuki <> "" Then
Dim buf As String, wb As Workbook
Dim Target As String
Target = "\\共有フォルダ\" tuki & "月度.xlsx"
''ファイルの存在チェック
buf = Dir(Target)
If buf = "" Then
MsgBox Target & vbCrLf & "は存在しません", vbExclamation
Exit Sub
End If
''同名ブックのチェック
For Each wb In Workbooks
If wb.Name = buf Then
MsgBox buf & vbCrLf & "はすでに開いています", vbExclamation
Exit Sub
End If
Next wb
''ここでブックを開く
Workbooks.Open Target
End If
End Sub
でファイルをオープンできるようにしてます。
ここで持たせたtukiからだせないか、出せないなら先に×月実績表でピポットを作ってそこから引っ張ってこれないかあれこれ考えてるところです。
わかりにくいとは思いますがよろしくお願いします。
（にゃん） 2018/05/21(月) 09:03
おはようございます。 ＾＾ 様々な方法が有ろうかと思いますが、tukiを Static か Public で定義する。 もしくは作業用シートを新規追加し、そのシートの任意のセルに書いておく Publicは信頼性に問題があるよ〜なので。。。セルに書き出しておいて 必要な場面（プロシジャ〜）で読み込む、が一番手間いらず、安全で簡単かもです。 ＾＾； （隠居じーさん） 2018/05/21(月) 10:21
作業月はセルで持たせるほうがいいんですね。
合算シート（1枚目のシート）のD1に持たせるようにします。
ちなみに×月実績表は
A B C D E F G H I J K L 〜 Q〜 X〜
受信日 発注日 期 年 月 卸CD 取引先CD 卸名 組織CD 品目CD 品目別 包装単位 〜 担当者名 金額
となってます。F〜Jは今回のには直接関係ないので省いてました。
よろしくお願いします。
（にゃん） 2018/05/21(月) 13:43
こんばんは ＾＾
種々方法はあると思いますが。わたしなりに。。。 ザックリですが下記の様な感じで出来そぉな気がしますけど。 只、三品目合計表示とOTHERでの多品目取り纏めには集計時に 品目マスターに分類別集計用の分類コード（目印になるもの）が必要かと。 作成済みであれば是非ご活用ください。 読込用の月別実績はk列が品目名、ｘ列が金額と云う事ですね。
開始 処理月選択 処理月実績読込 書込みシート選択 読込実績情報を品目名毎に個別、分類別集計（必要分だけ） 結果を書込みシートに格納、分類計は（instrか正規表現等で判定） 5シート分繰り返し 読込実績終了 終了
でわ （隠居じーさん） 2018/05/21(月) 16:58
X月実績表でピポットを組んでそこからひっぱて来るのが早いかなあと思ったのですが
A B C D
4 支店 担当者 品目 金額
5 ←明細はこの行から
これでいけば★実績表のA1からB列で担当者を探してC4（から5行おきに検索）、該当月にDの金額を入れればいいかなあと思ったのですがコードが思いつきません…
勉強不足で申し訳ないですがコードを教えて頂けないでしょうか…
（にゃん） 2018/05/21(月) 17:08
こんばんは ＾＾
＞X月実績表でピポットを組んでそこからひっぱて来るのが早いかなあと思ったのですが
すみません。可能なのではないでしょうか。なにせ年寄りなもので。。。エクセル、長い事 使っているのですが。３日前に初めてピボットなるものをこさえて見ました。便利ですね。 ＾＾ 。。。と云う程度の認識しかありませんで。（とほほ〜）ピボットからの転記は、他の方の 回答を、お待ちくださいね。お力になれず残念です。この学校は詳しい方もいらっしゃると 思いますです。
後で、回し(ループ）好きの、じーさんコード、アップしておきますね。何かの参考まで。
（隠居じーさん） 2018/05/21(月) 17:32
こんばんわぁ〜 ＾＾
合計シートの有るＢＯＯＫに
作業シート名 master 作成後下記情報を貼り付けてください。
今回IDと金額は使っていません。(実品目名に書き換えてください）
A B C D
1 ID 品名 区分 単価
2 10001 商品名A5 0 100
3 10002 商品名A11 0 200
4 10003 商品名A17 0 300
5 10004 商品名A23 0 400
6 10005 商品名A29 0 500
7 10006 商品名A35 0 600
8 10007 商品名A41 0 700
9 10008 商品名A47 0 800
10 10009 商品名A53 0 900
11 10010 商品名A59 0 1000
12 10011 商品名A65 0 1100
13 10012 商品名A71 0 1200
14 10013 商品名A77 0 1300
15 10014 商品名A83 0 1400
16 10015 商品名A89 0 1500
17 10016 やまかけ 1 600
18 10017 鍋焼き 1 800
19 10018 かけ 1 400
20 10019 たぬき 2 500
21 10020 きつね 2 550
22 10021 OTHER 3 10000
23 10022 OTHER2 3 250
24 10023 OTHER3 3 350
25 10024 OTHER4 3 450
26 10025 OTHER5 3 550
27 10026 OTHER6 3 650
28 10027 OTHER7 3 750
29 10028 OTHER8 3 850
30 10029 OTHER9 3 950
読込用実績は１行目は項目名 ２行目から実データ k列品目名、ｘ列金額
masterの品名はお使いの品名に替えてください。 読込対象シートsh01（Sheet1）はお使いの物に替えてください。 書込みシート名shnmはお使いの物に替えてください。 読込実績はパスBOOK名はそちらの環境に合わせてください。 が前程で。 例によって恐怖の憶測と推測コードなので動かなければ悪しからず ご了承ください。 フォルダ毎バックアップをお取りの上（必須） (;^_^A よければお試しください。
Option Explicit
Sub main()
Dim wb As Workbook
Dim sh01 As Worksheet, sh02 As Worksheet, sh03 As Worksheet
Dim i As Long, j As Long, shnm, rr As Range, k As Long
Dim fnm As String, hmast, kei, kukei
Set sh03 = Worksheets("master")
shnm = Array("d", "とまと", "だいこん", "たまねぎ", "ぴーまん", "れたす")
hmast = sh03.Range("A1").CurrentRegion
ReDim kei(UBound(hmast, 1))
ReDim kukei(1 To 3)
fnm = start(sh03)
If fnm = "False" Then Exit Sub
Workbooks.Open (fnm)
Set wb = ActiveWorkbook
Set sh01 = wb.Worksheets("Sheet1")
Set rr = sh01.Range("A1").CurrentRegion
ThisWorkbook.Activate
For i = 1 To UBound(shnm)
For Each sh02 In Worksheets
If shnm(i) = sh02.Name Then
sh02.Activate
For j = 2 To rr.Rows.Count
If sh02.Name = rr(j, 17) Then
For k = 1 To UBound(hmast)
If hmast(k, 2) = rr(j, 11) Then
kei(k) = kei(k) + rr(j, 24)
Select Case hmast(k, 3)
Case 1
kukei(1) = kukei(1) + rr(j, 24)
Case 2
kukei(2) = kukei(2) + rr(j, 24)
Case 3
kukei(3) = kukei(3) + rr(j, 24)
End Select
End If
kei(k) = IIf(IsEmpty(kei(k)), 0, kei(k))
Next
End If
Next
Call sh_write(sh02, sh03, kei, kukei, hmast)
ReDim kei(UBound(hmast, 1))
ReDim kukei(1 To 3)
End If
Next
Next
wb.Close
End Sub
Private Function start(ByVal sh As Worksheet) As String
Dim tmp
tmp = Application.InputBox("処理月を入力", Type:=1)
If CInt(tmp) Then
sh.Range("H1") = DateSerial(2018, tmp, 1)
start = ThisWorkbook.Path & "\" & Trim(StrConv(Str(tmp), vbWide) & "月実績表" & ".xlsm")
Else
start = "False"
End If
End Function
Private Sub sh_write(ByVal sh As Worksheet, ByVal master As Worksheet, _
ByVal kei As Variant, ByVal kukei As Variant, ByVal hm As Variant)
Dim re As Object
Dim trr As Range, i As Long, j, x As Long, cnt As Long, mc
Set re = CreateObject("VBScript.RegExp")
re.Global = True
j = DateValue(master.Range("H1"))
Set trr = sh.UsedRange
For i = 1 To trr.Columns.Count
If trr(4, i) = j Then
x = trr(4, i).Column
End If
Next
For i = 5 To trr.Rows.Count
If trr(i, 3) <> "" Then
For cnt = 2 To UBound(hm, 1)
If trr(i, 3) = hm(cnt, 2) Then
trr(i, x) = kei(cnt)
Else
re.Pattern = hm(cnt, 2)
Set mc = re.Execute(trr(i, 3))
If mc.Count > 0 And hm(cnt, 3) > 0 Then
trr(i, x) = kukei(hm(cnt, 3))
End If
End If
Next
End If
Next
End Sub
（隠居じーさん） 2018/05/21(月) 19:30
おはようございます ＾＾ 回答ではありませんが。。。単なるテストです。。。 http://www.relief.jp/docs/018038.html 参考に ピボット。。。作ってみました。 Set sh01 = Worksheets("Sheet1")を X月実績の実際のシート名に替えてくださいね。 ピボットに指定する項目名もお使いの物に替えてください。 X月実績のどれかに標準モージュールにコピペ コピペしたX月実績、単独でお試しを。 これもバックアップ必須です ＾＾；
取り込んだ情報をもとに、書き込むと、集計ルーチンは省けますね。 あまりステップ数は変わらないような。。。。。＾＾； 処理速度は分かりません。
Option Explicit
Sub main()
Dim sh01 As Worksheet, sh02 As Worksheet
Dim i As Long, j As Long, buf, rr As Range, r As Range
Dim pvc As PivotCache
Dim pvt As PivotTable
Set sh01 = Worksheets("Sheet1")
Set rr = sh01.Range("A1").CurrentRegion
Worksheets.Add
Set sh02 = ActiveSheet
Set pvc = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=rr)
Set pvt = pvc.CreatePivotTable(TableDestination:=sh02.Range("A1"))
With pvt
.PivotFields("金額").Orientation = xlDataField
.PivotFields("担当者").Orientation = xlColumnField
.PivotFields("品目").Orientation = xlRowField
End With
Set r = sh02.Range("A1").CurrentRegion
For i = 1 To r.Rows.Count
For j = 1 To r.Columns.Count
MsgBox r(i, j)
Next
Next
pvt.PivotSelect ""
Selection.Delete
sh02.Delete
End Sub
（隠居じーさん） 2018/05/22(火) 08:38
X月実績表でピポットを組んでそこからひっぱて来るのが早いかなあと思ったのですが 何度か今までの流れを読み返しましたが、今一つ解りません。
もし、まだ、アプリを作るにあたって方針が定まってないならば、
今一度以下の説明をお願いできませんか？
4月の実績表のデータをもらった。（担当者ごとに6つのシートに分かれて入力されている）
↓
2018年度実績一覧表に記入
↓
5月の実績表をもらった。
↓
2018年度実績一覧表に記入
↓
6月の。。。。
ということをするマクロを作るのですか？
その時の各月の実績表のイメージと
年度の実績一覧表（あるいは集計表？）のイメージを、
変に例えばの話ではなく、実際の項目名を使って説明してください。
ピボットテーブルで集計したものを、また組み直すのもありですが、
全部をピボットテーブルで集計できるように、
データを作り直す方向で考えた方が良いと思います。
実際にピボットテーブルの機能で意図する表を完璧に作るのは困難なので、
どうせは加工するのですが、
集計する前に各データを1件1行のリスト形式にしておけば、
ピボットテーブルを使っても使わなくても、
集計表を作ることが簡単になりますし、
エクセルの色々な機能や関数を使って分析的なことも出来るようになると思います。
もう、すでに方針が決まっっているという事なら、無視して構いません。
（まっつわん） 2018/05/22(火) 09:54
隠居じーさん さん
ピポットは私もマクロの記録から作成できてるのでそれを5行おきに検索して…で悩んでるところです。
頂いたコードでわからないところもあるので見てみます。ありがとうございます。
（にゃん） 2018/05/22(火) 13:31
すみませんshnm = Array("d", "とまと", "だいこん", "たまねぎ", "ぴーまん", "れたす")は
どこの部分になるのでしょう？
当てはまらない部分を書換ようと頑張ってますが理解が追い付かず申し訳ございません
（にゃん） 2018/05/22(火) 17:02
こんばんは ＾＾
＞shnm = Arrayshnm = Array("d", "とまと", "だいこん", "たまねぎ", "ぴーまん", "れたす")
ｄはダミーです（添え字を1からにする対策)
あとは書込み対象ＢＯＯＫの合計シート以外の５シートの（氏名）シート名です。
取り急ぎ、ご返信まで。 （隠居じーさん） 2018/05/22(火) 17:17
（にゃん） 2018/05/22(火) 17:24
いや〜。。。 ＾＾ 分かりにくくて済みません。今回のコードでは i = 0 to ... でも良かったのですが、普段は Waorksheets.Count と同期をとる場合が多く 添字、1からスタートが癖になっています。
＞添え字・・・？書き換えなくていいということでしょうか？ 添字 ＝ 配列の要素を参照、設定、する数値です。 一件目は（0）ダミーなので（使っていません）、何でもいいですが、１〜５は お使いの、シート名に変えてください。 私のテスト環境での５個のシート名とshnmの対応表 実際は存在しないシート "d" 。 。 。 。 shnm(0) に対応 "とまと"シート Ａ１は とまと さん shnm(1) に対応 "だいこん"シート Ａ１は だいこん さん shnm(2) "たまねぎ"シート Ａ１は たまねぎ さん shnm(3) "ぴーまん"シート Ａ１は ぴーまん さん shnm(4) "れたす"シート Ａ１は れたす さん shnm(5)
さん はありません
になっています。
Ａ１に記載の人名ではなくシート名で読込み実績の担当者を参照しています。
実際の担当者名と違う場合は22行目（多分）の
If sh02.Name = rr(j, 17) Then を
If sh02.Range("A1") = rr(j, 17) Thenに
変えてください。
A1の名前と読込み月別実績の担当者名は同じであると仮定してですが。
（隠居じーさん） 2018/05/22(火) 19:22
＞1品目に対して実績(ここに入れたい)
あぁ、じゃー簡単たんじゃないですか。。。
列はMatch関数で書き込む月を検索してそれの列番号で特定できますし、
行は、A列の値が入っているセルをジャンプ機能で検索して、
それらを基準にの1行下のセルに書き込めばいいですよね？
（まっつわん） 2018/05/22(火) 22:27
簡単・・・なんですかね？頭の中ではわかるんですけどコードに起こせなくて。
品目が合算してるのもあるのでピポットでくくったのを参照にしたほうが早いかなあと思っているのですが
ピポットだと×月実績表に集計表というシートを作って
A B C D
4 部署名 担当者名 品目名 金額
5 第一 山田 太郎 みかん 1000
・ ・ ・ ・ ・
・ ・ ・ ・ ・
21 山田 太郎集計 15000
22 第一 東京 次郎 みかん 800
・ ・ ・ ・ ・
・ ・ ・ ・ ・
39 東京 次郎集計 18000
となってます。MATCHをマクロで使用したことがないのと同じ作業を2シート目から5シート分繰り返すのがごちゃごちゃになってます。
隠居じいーさん さん
コードを参照に動かしてみます。
コードを全部理解してるわけではないので？？な所もありますががんばってみます。ありがとうございます。
（にゃん） 2018/05/23(水) 09:17
不要なデータを覗いたサンプルで、5列20行くらいの表で練習してから本番に向かうといいかもです。
あとは、とにかく根気ですね＾＾；
慣れてても1発でまともに動くプログラムはなかなか書けないので、
デバッグがとにかく大変だと思います。
頑張ってみてください。
あと、ホントイメージ湧かないなら、
本番データはさておいといて、
何個か練習問題的な課題を見つけて練習されてもいいかもです。
（まっつわん） 2018/05/23(水) 14:30
すみません頂いたコードを基に検証してますが根本がわかってないようで(汗)教えて頂きたいです。
作業シート名masterはピポットで作ったデータの貼り付けでいいのでしょうか
コードを追ってますがsh01,sh02,sh03がそれぞれどのシートを指すのかがわからなくなってしまってます。
sh01はsheet1？★実績表の1枚目のシートになるのでしょうか・・・
デバッグ以前の問題で申し訳ございませんがよろしくお願いします。
（にゃん） 2018/05/23(水) 16:10
え〜と ＾＾ sh01 は 読み込む月別実績のシートですシート名不明の為 "Sheet1" にしてます。 sh02 は 書込み対象の担当者名がシート名のシートです。 sh03 は 新規作成していただく品目マスタ用シートです。ここからマクロで配列に取り込んでます。
いずれにしても種別（複数品目計）の合計が必要なようなので区分コード（なにか識別するもの）は 必要かと。 ピボットは使っていません。読み込んだ実績をループで集計しています。 集計している部分がピボットに相当します。
コードに説明つけてみましたので、何かの参考に。。。＾＾； すこし見づらいかもです。
Option Explicit
Sub main()
Dim wb As Workbook
Dim sh01 As Worksheet, sh02 As Worksheet, sh03 As Worksheet
Dim i As Long, j As Long, shnm, rr As Range, k As Long
Dim fnm As String, hmast, kei, kukei
'品目マスター
Set sh03 = Worksheets("master")
'書込みシート名を配列に格納
shnm = Array("d", "とまと", "だいこん", "たまねぎ", "ぴーまん", "れたす")
'マスターを配列に取込
hmast = sh03.Range("A1").CurrentRegion
'集計用配列を品目マスターの品目数で再定義
ReDim kei(UBound(hmast, 1))
'品目マスターの区分コードゼロを除いたコード件数で再定義
ReDim kukei(1 To 3)
'読込ＢＯＯＫ名選択確定
fnm = start(sh03)
'取消なら終了（エラー処理無し）
If fnm = "False" Then Exit Sub
'読込用実績開く
Workbooks.Open (fnm)
'読込みＢＯＯＫをwbに格納
Set wb = ActiveWorkbook
'読込みＢＯＯＫの月実績シートをsh01に格納
Set sh01 = wb.Worksheets("Sheet1")
'読込み実績セル範囲をrrに格納
Set rr = sh01.Range("A1").CurrentRegion
ThisWorkbook.Activate
'シートName配列をループ
For i = 1 To UBound(shnm)
'書込み実シートを順次ループ（sh02に格納）
For Each sh02 In Worksheets
'配列シート名と書込み実シート名が一致
If shnm(i) = sh02.Name Then
'書込みシートをアクティブに
sh02.Activate
'読込み実績を２行目から順にループ
For j = 2 To rr.Rows.Count
'読込シートj行、17列（担当者）と書込みシートＡ１の名前が同じなら
If sh02.Range("A1") = rr(j, 17) Then
'品目マスターを１件目から順に一次元の最大要素数までループ
'（品目マスタの内容で個別、区分別集計実行）
'配列品目マスタの添え字と集計用配列の添え字を同じにする事でで品目名と金額合計が同期する
'同じく区分コードとkukeiも添え字で同期
For k = 1 To UBound(hmast)
'品目マスタの品目名と読込み実績、範囲rrの１１列目(k列品目）ｊ行が同じなら
If hmast(k, 2) = rr(j, 11) Then
'合計に合計と読込み実績金額を足算
kei(k) = kei(k) + rr(j, 24)
'配列hmastの一次元要素ｋ個目（品目）の、二次元要素3個目（区分コード）を選択調査
Select Case hmast(k, 3)
'区分コードが1ならkukei(1)に集計
Case 1
kukei(1) = kukei(1) + rr(j, 24)
'区分コードが2ならkukei(2)に集計
Case 2
kukei(2) = kukei(2) + rr(j, 24)
'区分コードが3ならkukei(3)に集計
Case 3
kukei(3) = kukei(3) + rr(j, 24)
'調査と集計終了
End Select
End If
'集計配列keiの添え字kの要素が初期状態（空）ならゼロを格納、以外は何もしない
kei(k) = IIf(IsEmpty(kei(k)), 0, kei(k))
'次の品目へ
Next
End If
'読込実績範囲rrの次の行へ
Next
'シート情報と計算結果、商品マスタ配列をパラメータで渡し、sh_writeサブプロシジャー呼び出し
Call sh_write(sh02, sh03, kei, kukei, hmast)
'集計用配列を再定義（初期化）
ReDim kei(UBound(hmast, 1))
ReDim kukei(1 To 3)
End If
'次の担当者名シートへ
Next
'配列shnmの次のシート名へ
Next
'読込んだ月別実績BOOKを閉じる
wb.Close
End Sub
Private Function start(ByVal sh As Worksheet) As String
Dim tmp
tmp = Application.InputBox("処理月を入力", Type:=1)
If CInt(tmp) Then
sh.Range("H1") = DateSerial(2018, tmp, 1)
start = ThisWorkbook.Path & "\" & Trim(StrConv(Str(tmp), vbWide) & "月実績表" & ".xlsm")
Else
start = "False"
End If
End Function
Private Sub sh_write(ByVal sh As Worksheet, ByVal master As Worksheet, _
ByVal kei As Variant, ByVal kukei As Variant, ByVal hm As Variant)
Dim re As Object
Dim trr As Range, i As Long, j, x As Long, cnt As Long, mc
'正規表現をreに格納
Set re = CreateObject("VBScript.RegExp")
'全文検索を可能に指定
re.Global = True
'処理月をmasterシートより読込み変数jに格納
j = DateValue(master.Range("H1"))
'担当者別書込みシートの全範囲をtrrに格納
Set trr = sh.UsedRange
'trrの4行目を調査､処理月の書込み列番号を取得、変数ｘに格納、FindかMatchでも
For i = 1 To trr.Columns.Count
If trr(4, i) = j Then
x = trr(4, i).Column
End If
Next
'書込みシートの5行目より最終行までループ
For i = 5 To trr.Rows.Count
'範囲trrのi行目、3列目（5〜6行飛び品目名に該当）が空白では無かったら
If trr(i, 3) <> "" Then
'配列品目マスタの二行目（一次元の2個目）より一次元の要素数までループ
For cnt = 2 To UBound(hm, 1)
'（ｃ列）品目名が品目マスタの添え字cntの要素（品目名）と同じなら
If trr(i, 3) = hm(cnt, 2) Then
'書込みシートの品目が記載されている行の処理月の列に合計の添え字cntの要素を格納
'ここで品目マスタの添え字を使い品目名に該当する合計値を（同期）書込み
trr(i, x) = kei(cnt)
'（ｃ列）品目名が品目マスタの添え字cntの要素（品目名）と違う場合
'品目名連記（品目名、品目名、品目名合算）の場合
Else
'パターンに品目マスタの品目名を格納
re.Pattern = hm(cnt, 2)
'ｃ列の品目名連記文字列に含まれているか調べる
Set mc = re.Execute(trr(i, 3))
'品目名が含まれていて、区分コードがゼロ以外なら（ゼロは個別集計で書込み済
'というか集計していないので）
'（区分コードが同じ品目の合計）を書込み。以外は何もしない
If mc.Count > 0 And hm(cnt, 3) > 0 Then
trr(i, x) = kukei(hm(cnt, 3))
End If
End If
Next
End If
Next
End Sub
（隠居じーさん） 2018/05/23(水) 16:30
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.