[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『複数シートのデータを別ブックに抽出』（ri-an）
売上帳から個別に取引先ごとのブックを作成したいと思っています。
ほぼマクロは無知で、売上帳も関数を調べ作成してあります。
売上帳は月別のシート12枚で作成してあります。
やりたいこと
・請求先ごとのブックを作成し、月売上、年間売上をだしたい。
・入力は売上帳のみにして、自動反映されればいいなと思っています。
・請求先ごとに振り分けて、その中で各現場の合計値も出したい。
別ブックにとばす時点でつまずいており助けていただきたいです。
Ａ Ｂ Ｃ Ｄ Ｅ Ｆ
１ 現場●● 請求先ａ 金額
２ 現場○○ 請求先ｂ 金額
３ 現場▲▲ 請求先ｃ 金額
４ 現場○○ 請求先ｂ 金額
５ 現場▲▲ 請求先ｃ 金額
という感じで月ごとにシート分けしてあります。
請求先は１０件ほどですが、現場数が多く、月をまたいで同じ現場があったりします。
よろしくお願いいたします。
＜ 使用 Excel：Excel2013、使用 OS：unknown ＞
わざわざお返事くれてありがとうございました。
もう少しいろんなサイト探してみます。
（ri-an） 2020/03/14(土) 10:20
過去ログを拝見したのですが、やはり難しく急ぎなので再度質問させていただきます。
【ＢＯＯＫ１】
Ａ Ｂ Ｃ Ｄ Ｅ Ｆ：Ｖ Ｘ Ｙ Ｚ
１ 番号 日付 現場名 施工会社 請求先 工事内容 売上 税額 請求額
２ １ ○/○ ○○工事 ○○社 Ａ社 ○○○ ○○円 ○円 ○○○円
３ ２ ○/○ ●●工事 ●●社 Ｂ社 ○○○ ○○円 ○円 ○○○円
４ ３ ○/○ ▲▲工事 ○○社 Ａ社 ○○○ ○○円 ○円 ○○○円
５ ４ ○/○ △△工事 △△社 Ｂ社 ○○○ ○○円 ○円 ○○○円
６ ５ ○/○ ■■工事 ○○社 Ｃ社 ○○○ ○○円 ○円 ○○○円
７ ６ ○/○ ○○工事 ○○社 Ａ社 ○○○ ○○円 ○円 ○○○円
８ ７ ○/○ △△工事 △△社 Ｂ社 ○○○ ○○円 ○円 ○○○円
と月ごとの１２シートで作成してあります。
やりたいことは
【ＢＯＯＫ２・Ａ社】
Ａ Ｂ Ｃ Ｄ ・・・ Ｍ Ｎ
１ 現場名 ３月 ４月 ５月 ・・・ ２月 合計
２ ○○工事 ○○円 ○○円 ○○円 ・・・ ○○円 ○○○円
３ ▲▲工事 ○○円 ○○円 ○○円 ・・・ ○○円 ○○○円
・
・
・
100 合計 ○○円 ○○円 ○○円 ・・・ ○○円 ○○○円
【ＢＯＯＫ３・Ｂ社】
【ＢＯＯＫ４・Ｃ社】
も同様に全部で２０社ぐらいあります。
現場名はひと月に100以上あります。
【ＢＯＯＫ１】には毎日入力するので、それが自動で他ＢＯＯＫに転記、集計されているようにしたいです。
よろしくお願いいたします。
（ri-an） 2020/03/14(土) 11:43
最初にお詫び。 紹介した記事は、ごく簡単なデータを前提としたものでした。 このケースでは使えません。申し訳なかったです。
＞ほぼマクロは無知で
ということでしたら、なおさらピボットテーブルの活用を検討されては。
1. 一つのシートにデータをまとめます。
2．これをもとにピボットテーブルを作ります。
3．請求先を ページ（レポートフィルター？）
行は、現場名、
列は、日付
値は、請求額
4．日付に関して、月でグループ化します。
これで作表できるはずです。
いったん、ピボットテーブルを作ってしまえば、データ範囲の更新で データの即時反映はできます。
なお、PowerQueryを使えば、各シートを一つのシートに取り込むことができます。 慣れが必要になるかもしれません。
もちろん、すべてマクロで書くこともできるでしょうけど、 私自身は書くつもりはありません。 ピボットテーブルを活用したほうがよいという考えです。 中途半端で申し訳ないが、まずは、前発言の訂正まで。 （γ） 2020/03/15(日) 18:16
＞1.一つのシートにデータをまとめます。
ですが、12か月分のシートの後ろ13シート目に全業者全現場まとめてあります。
行が1000を超えている状況で、現場名ごとにフィルターで検索？？して探してもよいのですが、数が膨大なのと、そこから金額を電卓で計算しています。
＞2.これをもとにピボットテーブルを作ります。
別のブックに作成できますでしょうか？？
12シート分を別ブックのシート1に集計したいです。
『PowerQuery』はお恥ずかしいのですが、初めて聞いた言葉です。。。
調べてみます。
（ri-an） 2020/03/16(月) 09:20
各シートの終わり行は月ごとで変速で、13シート目も請求先、現場名が増えれば行も増えるので固定ではないです。
PowerQueryは行の変化に弱い。と記載があったのですが、うまく使えますか？？
（ri-an） 2020/03/16(月) 10:00
どうやらExcel2010みたいでパワークエリができないみたいです。
ダウンロードをしようと思いましたが、64bitがどうたら…って話で、ダウンロードできませんでした。
（ri-an） 2020/03/16(月) 10:55
こんにちは ＾＾ あの〜。。。13シート目、に年間情報、全件ある のなら、必要ないのでは。。。 気が付いた点だけですみません。m(_ _)m （隠居じーさん） 2020/03/16(月) 11:27
隠居じーさん
年間情報全件ありますが
現時点での年間情報は、行：請求先、列：月の請求額です。
新規で請求先が来た場合は、年間情報のリストに手作業で請求先を入力しています。
例えば4月に取引をさせていただいたとして、それ以降取引がなく12月にまた取引があった場合、忘れてしまってまた手作業で年間情報に入力してしまう。
結果年間情報のシート内に重複した請求先があり、その行を削除している。という流れです。
請求先ごとのブックを作成し、行：現場名、列：月にしたいのです。
現場名ごとの年間合計値を出したいのと、請求先ごとにどこの現場名が請求額高かったか。という順位ものちに作成したいと思っています。
説明がうまくできず申し訳ありません。。。
（ri-an） 2020/03/16(月) 12:08
こんにちは ＾＾ いろいろ、ご事情もあるようで、で、12シートに分かれている年間情報は 正しい、情報なのでしょうか。ご提示の表を拝見する限り、番号（取引？、 伝票番号？）と日付、と取引先（請求先）で一意な【ユニーク】情報には なっているとは思いますが。 ＞＞例えば4月に取引をさせていただいたとして、それ以降取引がなく12月にまた取引があった場合、忘れて ＞＞しまってまた手作業で年間情報に入力してしまう。 反対にいれとかないと、請求漏れになってしまうのでは？ いずれにしましても、とりあえず、お急ぎでしたら、効率化は後日の課題として 年間情報は、手作業で12シート分コピペで取り纏めてもそう、手間はかからないのでは ないでしょうか。で、それを使い、データー、フイルター、詳細等で得意先別に分けれますので それをピボットテーブルにすれば、比較的簡単に、お望みの情報が出来るかと思います。 （隠居じーさん） 2020/03/16(月) 13:24
番号はあってもなくてもいいんですが、入社したときからありましたのでそのままになっています笑
年間情報のシートに現場名の列をいれた方がいいのでしょうか？？
大変な量になってしまうと思い、月の請求額のみ出るようになっているので、合計値の内訳は年間情報にはのりません。
（ri-an） 2020/03/16(月) 13:59
|[A] |[B] |[C] |[D] |[E] |[F] |[G] |[H] |[I] |[J] |[K] |[L] |[M] |[N]
[1] |請求先 - A |2020 - 04 |2020 - 05 |2020 - 06 |2020 - 07 |2020 - 08 |2020 - 09 |2020 - 10 |2020 - 11 |2020 - 12 |2021 - 01 |2021 - 02 |2021 - 03 |総計
[2] |現場名称 - 001| 2,934,700| | | 4,080,400| | 346,200| | 1,666,700| 8,487,700| |15,252,000| | 32,767,700
[3] |現場名称 - 002| | 5,247,900| 7,156,800| | | 9,853,400|19,043,900|14,233,600|11,081,000|11,961,400| |16,883,000| 95,461,000
[4] |現場名称 - 003| | | 3,282,900| | 6,314,200|14,321,200|38,889,800| 7,219,800|10,586,100| 5,491,800| | | 86,105,800
[5] |現場名称 - 004| | 1,672,900| 6,643,000| | 4,975,000| | | 7,608,600| 8,946,300|12,745,900| 659,200| | 43,250,900
[6] |現場名称 - 005| | | 8,391,100| | 4,104,400| | | 9,424,400| 1,920,300| | | 4,837,800| 28,678,000
[7] |現場名称 - 006| 6,106,100| 9,722,700| 6,720,600| 8,593,400|23,349,400|13,658,200| 9,107,900| 1,111,500| | 3,276,100|14,087,600| | 95,733,500
[8] |現場名称 - 007| 1,555,600|10,482,900| | 4,980,400| 8,884,700| | 9,191,400| |11,419,100| 6,123,000| | | 52,637,100
[9] |現場名称 - 008|10,471,100|24,959,000| 5,783,200| 7,107,800| | 6,491,400| | 6,733,100| | | 6,557,800| 5,614,900| 73,718,300
[10]|現場名称 - 009| | 6,210,200| 4,237,700| 6,810,200|15,389,700|20,335,500| 5,205,700| | | 1,864,700| | 9,492,400| 69,546,100
[11]|現場名称 - 010| 1,320,000|25,105,900| 7,716,000| 7,719,300| | |15,310,200| 6,432,500| 5,499,000| 6,007,800| 4,093,600| 5,796,800| 85,001,100
[12]|総計 |22,387,500|83,401,500|49,931,300|39,291,500|63,017,400|65,005,900|96,748,900|54,430,200|57,939,500|47,470,700|40,650,200|42,624,900|662,899,500
こんにちは ＾＾ ↑ の様な感じで良いのであればri-anさんのお望みの項目にもよりますが。。。 番号 日付 現場名 施工会社 請求先 金額 税金 合計 月（2020 - 04） これくらいで。。。使わない項目もありますが気が変わる事も ＾＾； （隠居じーさん） 2020/03/16(月) 14:14
こんにちは!(^^)!
これです！！！！！！！
これは現場名称-011が来た場合、自動で行11,12の間に入ってきますでしょうか？？
月に何度も同じ現場名称に行きますので、現場名称-001は2020-04の合計金額でしょうか？？
（ri-an） 2020/03/16(月) 14:34
あ。はい、すこし手は加えてますが概ね。。。 そうなります。仮情報なのででたらめで、整合性はありませんが、感じだけでも ＾＾；。。。m(_ _)m ピボットはかなりべんりなので、γ さんも お勧めだったと思います。 ＞＞大変な量になってしまうと思い、月の請求額のみ出るようになっているので、合計値の内訳は年間情報に ＞＞はのりません。 失礼致しました。と云う事でしたら 合計（税込）値 だけで、税金、と金額【売上相当分】 はいらないですね。 m(_ _)m （隠居じーさん） 2020/03/16(月) 14:40
請求先ごとのブックで、行は現場名称にしたいです。
初めに何からすればよいですか？？
年間情報から作り直しですよね？？
（ri-an） 2020/03/16(月) 14:49
はい。年間情報が基本になりますので。。。大雑把に説明いたしますと、下記の様な事に 1.年間情報 2.1.と請求先一覧、を使いデーター、フイルター詳細、で請求先単位で別シートに纏めます ３．ピボットを２〜３列右隣に作り、コピペで値貼付けにし、体裁を整えて、左の要らない列を削除 名前を付けて保存、 4.２〜３を全請求先分繰り返して終わりです。だったと思います。。。＾＾； m(_ _)m
（隠居じーさん） 2020/03/16(月) 15:06
こんにちは ＾＾ 可能ですが。。。私ですと ← 関数が全く苦手。。。ほとんど解らない。。。（＾◇＾）。。＾＾； マクロになってしまいます。関数をご希望でしたら、他の回答者様のアドバイスをお待ちくださいね。 ただ、ある程度お解りで無い場合、マクロはあまりお勧め出来ません。ご自分で作成されるのでしたら、お手伝い 位はさせて戴きますが。。。m(_ _)m 元情報作成でしたらそんなに難しくはないかと、ピボットは作って おけば、情報が変わっても更新は出来るようです。ただ、ＢＯＯＫにまで自動反映となるといささか難易 度が。。。マクロならピボットを使うか、そのままついでにマクロで集計してしまうか悩ましい処です。 いずれにしても難易度は高くなるでしょう。。。(￣▽￣)。。。。m(_ _)m でわ
（隠居じーさん） 2020/03/16(月) 15:50
大変ご迷惑だとは思いますが、質問しながら作成できればいいな。と思っております。
素人なのに、やりたいことだけ一人前みたいなこと言ってますよね。。。。
すみません。。。
（ri-an） 2020/03/16(月) 15:58
あ、いえ！。。。わたしも、素人ですし。。。 じゃ ＾＾； ま。 とりあえず12シートを纏めるとこらからでも。。。 ループ とか 変数、つてお解りですか。
（隠居じーさん） 2020/03/16(月) 16:32
ちょっとその前に、売上帳をの2行目ですが項目分かれみたいに行2.3.4を結合していて一つのセルにしているのですが、その時点でアウトじゃないでしょうか？？？？？？
（ri-an） 2020/03/16(月) 16:49
えーと ＾＾ アウトとはいいきれませんで 実際の項目レイアウトを教えていただけますか。 実データーは5行目からでしょうか。 名称等は違いさえ分かれば、偽情報で。。。＾＾； 取得すべき数項目分だけで結構ですので （隠居じーさん） 2020/03/16(月) 17:08
横から失礼します。 2020/03/14(土) 11:43で投稿されている表の"F:V"ってセルを結合しているということですよね？ その結合を外せるのであれば(ピボットテーブルは結合セルがあると設定できないので) 売上帳に下記のサイトから合うマクロを設定し会社別のブックにピボットテーブルを設定したらいいのではないのでしょうか？ http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_data_matome.html （だいず） 2020/03/16(月) 17:13
Ａ Ｂ Ｃ Ｄ Ｅ Ｆ：Ｖ Ｘ Ｙ Ｚ
１ ２ 番号 日付 現場名 施工会社 請求先 工事内容 売上 税額 請求額 ３
４ ５ １ ○/○ ○○工事 ○○社 Ａ社 ○○○ ○○円 ○円 ○○○円 ６
７ ８ ２ ○/○ ●●工事 ●●社 Ｂ社 ○○○ ○○円 ○円 ○○○円 ９
というように行は3行で1行扱いです。
実データは4行目からになります。
（ri-an） 2020/03/16(月) 17:58
＞"F:V"ってセルを結合しているということですよね？
Ｆ〜Ｖは結合はしておらず、工事内容が何項目かに分かれておりますのでこのような表現をいたしました。
まとめたときに列に不必要な部分でしたので、省略して書かせていただきました。
（ri-an） 2020/03/16(月) 18:02
こんばんは ＾＾ 了解致しました。 各項目(列)、全て縦（3行）に結合されているとの認識で合っていますでしょうか 必ず入力されている項目は番号、日付、請求先との認識でよろしいですか。 m(_ _)m （隠居じーさん） 2020/03/16(月) 18:18
今晩は＾＾ あの〜。。。あと日付は、シリアル値ですよね。それとも 文字列でせうか ご説明では、項目の行も（1,2,3行）結合されていますか。 質問ばかりで済みませんが、この辺が違っていると最初から蹴躓く様な事になるかもでして、でわ。。。m(_ _)m （隠居じーさん） 2020/03/16(月) 19:15
全て３行使って結合してあります!!!!
セル１つが行３ずつです。
項目から全て行３ずつです。
日付はシリアル値になっています!!!!
１２ヶ月分のシート全てこの形で最終行は月によって違います…
（ri-an） 2020/03/16(月) 22:14
こんばんは ＾＾ 下記コードを実行すれば実験用の仮情報が作成されます、実際の年間情報とフォーマット が違う箇所があれば又ご連絡ください。
Option Explicit
'新規フォルダ（名前は何でも）に新規BOOKにこのコードを貼り付け
'、テキトーな名前で【拡張子はxlsmで】保存してから下記コードを実行してください
'長い名前で使いにくければ、お使いのシステムに 売上帳.xlsx が
'無い場合は 売上帳.xlsxに名前を
'変えて下さい
Sub zDummyDataMaker()
Dim i As Long
Dim Rnum As Long
Dim Tnum As Long
Dim zGyo As Long
Dim zRetu As Long
Dim Snm As String
Dim zDate As Date
Dim zM As Long
Dim Wb As Workbook
If Not Dir(ThisWorkbook.Path & "\" & "A{DF800D74-07CE-4EB5-BD40-6123602D1196}売上帳.xlsx") = "" Then
Kill ThisWorkbook.Path & "\" & "A{DF800D74-07CE-4EB5-BD40-6123602D1196}売上帳.xlsx"
End If
WsDeleteA ThisWorkbook
Rnd -3
zDate = (DateSerial(2020, 4, 1))
Do Until zDate > DateSerial(2021, 3, 31)
If zM <> Month(zDate) Then
If Snm <> "" Then Worksheets(Snm).UsedRange.EntireColumn.AutoFit
zM = Month(zDate)
zGyo = 1
Snm = zM
If Not Evaluate("=ISREF(" & Snm & "!A1)") Then
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = Snm
Worksheets(Snm).UsedRange.Clear
End If
With Worksheets(Snm)
.Cells(zGyo, 1).Resize(, 5) = Array("番号", "日付", "現場名", "施工会社", "請求先")
For zRetu = 6 To 23
.Cells(zGyo, zRetu) = "工事内容 - " & Format(zRetu, "00")
Next
.Cells(zGyo, 24) = "金額"
.Cells(zGyo, 25) = "税金"
.Cells(zGyo, 26) = "合計"
For zRetu = 1 To 26
.Range(.Cells(zGyo, zRetu), .Cells(zGyo, zRetu).Offset(2)).Merge
Next
.UsedRange.EntireColumn.AutoFit
End With
End If
With Worksheets(Snm)
Rnum = Int((15 - 3 + 1) * Rnd + 3)
For i = 1 To Rnum
Tnum = Tnum + 1
zGyo = zGyo + 3
.Cells(zGyo, 1) = Tnum
.Cells(zGyo, 2) = zDate
.Cells(zGyo, 3) = "現場名称 - " & Format(Int((10 - 1 + 1) * Rnd + 1), "000")
.Cells(zGyo, 4) = "施工会社 - " & Format(Int((10 - 1 + 1) * Rnd + 1), "000")
.Cells(zGyo, 5) = "請求先 - " & Chr(Int((85 - 65 + 1) * Rnd + 65))
For zRetu = 6 To 23
.Cells(zGyo, zRetu) = "工事内容 - " & .Cells(zGyo, zRetu).Address(0, 0)
Next
.Cells(zGyo, 24).NumberFormatLocal = "#,##0"
.Cells(zGyo, 25).NumberFormatLocal = "#,##0"
.Cells(zGyo, 26).NumberFormatLocal = "#,##0"
.Cells(zGyo, 24) = Int((99999 - 10 + 1) * Rnd + 10) * 100
.Cells(zGyo, 25) = .Cells(zGyo, 24) * 0.1
.Cells(zGyo, 26) = .Cells(zGyo, 24) + .Cells(zGyo, 25)
For zRetu = 1 To 26
.Range(.Cells(zGyo, zRetu), .Cells(zGyo, zRetu).Offset(2)).Merge
Next
Next
End With
zDate = zDate + 1
DoEvents
Loop
Worksheets(Snm).UsedRange.EntireColumn.AutoFit
Worksheets.Copy
Set Wb = ActiveWorkbook
Wb.SaveAs ThisWorkbook.Path & "\" & "A{DF800D74-07CE-4EB5-BD40-6123602D1196}売上帳.xlsx", 51
WsDeleteB Wb
Wb.Close True
WsDeleteA ThisWorkbook
Set Wb = Nothing
End Sub
Private Sub WsDeleteA(ByVal Wb As Workbook)
Dim i As Long
Application.DisplayAlerts = False
For i = Wb.Worksheets.Count To 1 Step -1
If Sheets(i).Name <> "Sheet1" And _
Sheets(i).Name <> "Sheet2" And _
Sheets(i).Name <> "Sheet3" Then
Sheets(i).Delete
End If
Next
Application.DisplayAlerts = True
End Sub
Private Sub WsDeleteB(ByVal Wb As Workbook)
Dim zSnm() As Variant
Dim InvFlg As Boolean
Dim i As Long
Dim Ws As Variant
zSnm = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
Application.DisplayAlerts = False
For i = Wb.Worksheets.Count To 1 Step -1
InvFlg = True
For Each Ws In zSnm
If Wb.Worksheets(i).Name = CStr(Ws) Then
InvFlg = False
Exit For
End If
Next
If InvFlg Then
Wb.Worksheets(i).Delete
End If
Next
Application.DisplayAlerts = True
End Sub
（隠居じーさん） 2020/03/16(月) 22:45
午後出勤でしたので、今からやってみます^-^
また質問させてください♪
（ri-an） 2020/03/17(火) 13:02
・新ブックにシート名【４〜３】が作成された。
・日付は2020/4/1からスタートしていた。
・現場名-1〜の表示で元シートの現場名が反映されなかった。
・工事内容が膨大な量で反映された。
そして何が出来たか理解できなかった。。。泣
年間情報をまず作り直します。
ここに現場名をすべて入れておかないといけませんよね？？
（ri-an） 2020/03/17(火) 14:46
こんにちは ＾＾ 変な物作ってすみません。m(_ _)m 2〜３ 行で良いので、実際の年間情報（工事内容は無視して戴いて ＾＾；） 日付、現場名、請求先、合計のセルの位置が」合っているかご確認お願いいた します。先日、提示させて戴いた見本は配置は違いますがここから引き出して います (￣▽￣)。。。m(_ _)m （隠居じーさん） 2020/03/17(火) 15:13
シート名からですが5月スタートなので
R1.5〜R2.4で12シートあります。
この12シートのフォームは↑に記載したものになります。
Ａ：管理?ａiまとめる際必要ない）
Ｂ：日付（まとめる際必要ない）
Ｃ：現場名
Ｄ：施工会社
Ｅ：請求先
Ｆ〜Ｖ：工事内容（まとめる際必要ない）
Ｘ：売上
Ｙ：税
Ｚ：請求額
AA〜AE：入金状況（まとめる際必要ない）
（ri-an） 2020/03/17(火) 15:37
というより、請求額からの入金があるかの確認をするためのシートになります。
2行目
Ｅ〜Ｊ：R1.5
Ｋ〜Ｐ：R1.6
・
・
BS〜BX：R2.4
3行目
Ａ：締日
Ｂ：かな
Ｃ：請求先
Ｄ：前年度残
Ｅ：請求額
Ｆ：翌月請求予定
Ｇ：入金額
Ｈ：手数料
Ｉ：その他
Ｊ：残
実データは4行目からになります。
こちらの情報は請求先に対しての月の請求額のみ表示になっており、現場ごとの情報は全くのりません。
（ri-an） 2020/03/17(火) 15:49
いらない列の削除の仕方がいまいち分かりません。。。
（ri-an） 2020/03/17(火) 15:52
こんにちは ＾＾ ご提示させて戴いた見本と一応、セル位置、フォーマットは合っていると理解致します。 では、ある程度、お解りでしたら、このサンプルの変な名前のＢＯＯＫを読み込んで、 全てのシートの名前を表示するコードを書いてみて下さい。可能でしたら、1〜３行 とばしで、どの列でも良いので隣のシートへでも書き出して見て下さい（取り出せるか 「位置が合っているか確認できます。] （隠居じーさん） 2020/03/17(火) 16:18
ある程度どころか、ほぼ分かりません。
申し訳ありません。
（ri-an） 2020/03/17(火) 16:26
いえいえ、なにも、申し訳ない事などありはいたしません。 わたしもいい加減なものでして、何も覚えていないのですが 困ったときに調べ方くらいが何となくわかる程度です。 （隠居じーさん） 2020/03/17(火) 16:37
こんばんは ＾＾ お役に立つかどうかははなはだ疑問ですが、今後のご考察の 一助にでもなれば幸甚です。 お送りした変な名前の売上帳と同じフォルダに適当な名前の マクロ対応ＢＯＯＫ（拡張子 xlsm）を保存し、下記コード をコピペ後、お試しを。 m(_ _)m
Option Explicit
Sub zGetBaseDataAL()
Const zBnm As String = "A{DF800D74-07CE-4EB5-BD40-6123602D1196}売上帳.xlsx"
Const zSCnt As Long = 2971
Const zSG As Currency = 16443948070@
Dim i As Long
Dim xSg As Currency
Dim Tb As Workbook
Dim TWs As Worksheet
Dim Wb As Workbook
Dim Ws As Worksheet
Dim zGyo As Long
Set Tb = ThisWorkbook
If Dir(Tb.Path & "\" & zBnm) = zBnm Then
Set Wb = Workbooks.Open(Tb.Path & "\" & zBnm)
Else
Set Tb = Nothing
MsgBox "売上帳ファイルが有りません", vbCritical
End
End If
Set TWs = Tb.Worksheets("Sheet1")
With TWs
.UsedRange.Clear
.Cells(1).Resize(, 4) = Array("日付", "現場名", "請求先", "合計")
i = 2
For Each Ws In Wb.Worksheets
With Ws
.Activate
For zGyo = 4 To .Cells(.Rows.Count, 2).End(xlUp).Row + 1 Step 3
TWs.Cells(i, 1) = .Cells(zGyo, 2)
TWs.Cells(i, 1).NumberFormatLocal = "yyyy/mm/dd"
TWs.Cells(i, 2) = .Cells(zGyo, 3)
TWs.Cells(i, 3) = .Cells(zGyo, 5)
TWs.Cells(i, 4) = .Cells(zGyo, 26)
xSg = xSg + TWs.Cells(i, 4)
i = i + 1
Next
End With
DoEvents
Next
.UsedRange.EntireColumn.AutoFit
If i - 2 = zSCnt And xSg = zSG Then
MsgBox "読込に成功しました" & Chr(13) & i - 2 & Chr(13) & xSg
Else
MsgBox "読込失敗、終了します" & Chr(13) & i - 2 & Chr(13) & Format(zSG, "#,##0"), vbCritical
.Cells.Delete
End If
.Activate
.Cells(1).Select
End With
Wb.Close False
Set TWs = Nothing
Set Wb = Nothing
Set Tb = Nothing
End Sub
（隠居じーさん） 2020/03/17(火) 17:05
まず初めに作っていただいたコードの
＞Const zBnm As String = "A{DF800D74-07CE-4EB5-BD40-6123602D1196}売上帳.xlsx"
の″″の中を年間情報に変更してみます。
次に
＞zDate = (DateSerial(2020, 4, 1))
Do Until zDate > DateSerial(2021, 3, 31)
の日付を変更してみます。
ここは変な日付と言ってしまってすみませんでした。
こちらもシート分けの説明をしていなかったので過程で設定してくれただけですよね。。。
すみません。
頑張ります♪♪
（ri-an） 2020/03/17(火) 17:36
（隠居じーさん） 2020/03/17(火) 17:48
こんにちは
＞＞まず初めに作っていただいたコードの
＞＞Const zBnm As String = "A{DF800D74-07CE-4EB5-BD40-6123602D1196}売上帳.xlsx"
＞＞の″″の中を年間情報に変更してみます。
先ほど気が付いたのですが。↑ はやらないほうがいいです。テスト情報を共有するための ダミー情報を作成するコードなので、一番最初にそのファイルが有れば初期化されます。 ダミー作成時も同一ファイル名と万が一にもかぶらないため、敢えて長い一意なファイル名に 致しております。 （隠居じーさん） 2020/03/17(火) 17:05 のほうは変えていただいても読み取りのみなので影響はございません。← こちらの事と 思い込んでいましたもので返信が遅く成り恐縮です。多少。。。まさかとはおもいましたので バックアップはお勧めした次第です。m(_ _)m。。。何事もありませんように。。。 （隠居じーさん） 2020/03/18(水) 15:38
本日外回りをしておりましたので、まだやってないですｗｗｗ
わざわざありがとうございます♪
日付は2019/5〜2020/4に変更しても大丈夫なのでしょうか？？
（ri-an） 2020/03/18(水) 17:49
こんばんは ＾＾ いや〜 よかったです。大事な情報だとおもいますので。。。 ＞＞日付は2019/5〜2020/4に変更しても大丈夫なのでしょうか？？ ファイル名部分がそのままなら変更して戴いた期間のダミー情報が 作成されるだけです。 ← どうなるか やってみます。 ＾＾； m(_ _)m （隠居じーさん） 2020/03/18(水) 17:56
こんばんは ＾＾
zDate = (DateSerial(2019, 5, 1))
Do Until zDate > DateSerial(2020, 4, 30)
で
ダミー情報総金額=16,463,719,910 総処理件数=2974
で、作成、されました。
m(_ _)m
（隠居じーさん） 2020/03/18(水) 19:06
こんばんは ＾＾
一応、作っては見ましたが、多分このままではお役には立たないかと A＾＾；
使用情報はあくまで想像の範囲でしかありませんし、あまり自信もありません
今後のご考察の際の何かの足しにでも。。。ならなければゴミ箱ぽい。。おねがい
いたします。(#^.^#) では、
あ！ バックアップ & テスト & バグつぶし。。は必須です （＾◇＾）ｖ。。。m(_ _)m
いいかげんな回答で済みません、他の方の回答もお待ちくださいませ。
Option Explicit
'**********************************************************
'* Pivotを使わない計算版
'* 月間集計金額の並びの自由化のためあえてオーソドックスなロジックです
'* 表示月数は１２か月限定、固定、以外は不対応
'* ※年を跨ぐ情報には不対応です。１２か月未満は情報の無い月はゼロ表示
'* ダミー情報総金額 総処理件数 作成方法により変化
'**********************************************************
Sub zOneInstanceMainNoPivot02()
Dim zT As Date
zT = Timer
zExecuteSelect02
zSheetChk
zFileInitialize02
zGetBaseData02
Pstart02
zMakeCustomerAggregate02
Pend02
MsgBox "処理が完了しました " & Format(Timer - zT, "0.0") & " 秒"
End Sub
Private Sub zSheetChk()
Dim Ws As Worksheet
For Each Ws In ThisWorkbook.Worksheets
If Ws.Name = "TMPXXX" Then
MsgBox "初期化されるシート【 TMPXXX 】が存在します。シート名を変更してください"
End
End If
Next
End Sub
Private Sub zExecuteSelect02()
Dim zVar As Variant
zVar = MsgBox("以前に作成した請求先ファイルは削除されます" & Chr(13) & _
"Sheet1 は書き換えられます", vbOKCancel)
If Not zVar = 1 Then
End
End If
End Sub
Private Sub zMakeCustomerAggregate02()
'表示される月は１２ヶ月固定です
Dim i As Long
Dim j As Long
Dim zY As Long
Dim zVar As Variant
Dim zVar2 As Variant
Dim zR As Range
Dim zRR As Range
Dim zD As Object
Dim Snm As String
Dim Bary() As Variant
Dim Gary() As Variant
Dim zBox() As Variant
Dim zDic() As Variant
Dim MasT As Object
Dim MasG As Object
Set MasT = CreateObject("Scripting.Dictionary")
Set zD = CreateObject("Scripting.Dictionary")
Set MasG = CreateObject("Scripting.Dictionary")
For i = DateSerial(2019, 5, 1) To DateSerial(2020, 4, 30)
zD(Month(i)) = i
Next
With Worksheets("Sheet1")
Bary = .Cells(1).CurrentRegion.Value
For i = 2 To UBound(Bary, 1)
MasT(Bary(i, 3)) = Empty
DoEvents
Next
End With
Snm = "TMPXXX"
If Not Evaluate("=ISREF(" & Snm & "!A1)") Then Sheets.Add.Name = Snm
With Worksheets(Snm)
For Each zVar In MasT
.Activate
.Cells.Delete
.Cells(1).Resize(UBound(Bary, 1), UBound(Bary, 2)) = Bary
.Cells(1, "K") = Bary(1, 3)
.Cells(2, "K") = zVar
.Cells(1).CurrentRegion.AdvancedFilter xlFilterCopy, .Range("K1:K2"), .Range("M1"), False
.Range("A:L").Delete
Gary = .Cells(1).CurrentRegion.Value
For i = 2 To UBound(Gary, 1)
ReDim zBox(1 To zD.Count)
j = 0
For Each zVar2 In zD
j = j + 1
If Month(Gary(i, 1)) = zVar2 Then
zBox(j) = Gary(i, 4)
End If
Next
If Not MasG.Exists(Gary(i, 2)) Then
MasG(Gary(i, 2)) = zBox
Else
zDic = MasG(Gary(i, 2))
For j = LBound(zDic) To UBound(zDic)
zDic(j) = zDic(j) + zBox(j)
Next
MasG(Gary(i, 2)) = zDic
Erase zDic
End If
Application.StatusBar = Space$(5) & zVar & " を処理中 " & i & " 件目"
DoEvents
Next
.Cells(1, 11).Resize(1, UBound(zD.items) + 1) = zD.items
.Cells(1, 11).Resize(1, UBound(zD.items) + 1).NumberFormatLocal = "yyyy - mm"
zY = 2
For Each zVar2 In MasG
.Cells(zY, 10) = zVar2
For i = LBound(MasG(zVar2)) To UBound(MasG(zVar2))
.Cells(zY, 10 + i) = MasG(zVar2)(i)
Next
zY = zY + 1
Next
.Cells(1, 10) = zVar
Set zR = .Cells(1, 10).CurrentRegion
zR.Sort Key1:=.Cells(1, 10), Order1:=xlAscending, Header:=xlYes
zR.Offset(1, 1).NumberFormatLocal = "#,##0"
With zR(1).Offset(zR.Rows.Count, 1).Resize(, zR.Columns.Count - 1)
.Formula = "=sum(r[-" & zR.Rows.Count - 1 & "]c:r[-1]c)"
.Value = .Value
End With
With zR(zR.Columns.Count).Offset(1, 1).Resize(zR.Rows.Count, 1)
.Formula = "=sum(rc[-" & zR.Columns.Count - 1 & "]:rc[-1])"
.Value = .Value
End With
zR(1).Offset(zR.Rows.Count) = "合 計"
zR(1).Offset(, zR.Columns.Count) = " 総 合 計"
.UsedRange.ColumnWidth = 12.5
.Range("A:I").Delete
.Range("A:A").ColumnWidth = 15
MasG.RemoveAll
.Copy
ActiveWorkbook.Worksheets(1).Name = zVar
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & zVar & ".xlsx", 51
ActiveWorkbook.Close False
DoEvents
Next
End With
Worksheets(Snm).Delete
Erase Bary, zBox
Set MasT = Nothing
Set MasG = Nothing
Set zD = Nothing
Set zR = Nothing
Set zRR = Nothing
Application.StatusBar = False
End Sub
Private Sub zGetBaseData02()
Const zBnm As String = "A{DF800D74-07CE-4EB5-BD40-6123602D1196}売上帳.xlsx"
Dim i As Long
Dim xSg As Currency
Dim Tb As Workbook
Dim TWs As Worksheet
Dim Wb As Workbook
Dim Ws As Worksheet
Dim zGyo As Long
Set Tb = ThisWorkbook
If Dir(Tb.Path & "\" & zBnm) = zBnm Then
Set Wb = Workbooks.Open(Tb.Path & "\" & zBnm)
Else
Set Tb = Nothing
MsgBox "売上帳ファイルが有りません", vbCritical
End
End If
Set TWs = Tb.Worksheets("Sheet1")
With TWs
.UsedRange.Clear
.Cells(1).Resize(, 4) = Array("日付", "現場名", "請求先", "合計")
i = 2
For Each Ws In Wb.Worksheets
With Ws
.Activate
For zGyo = 4 To .Cells(.Rows.Count, 2).End(xlUp).Row + 1 Step 3
TWs.Cells(i, 1) = .Cells(zGyo, 2)
TWs.Cells(i, 2) = .Cells(zGyo, 3)
TWs.Cells(i, 2).NumberFormatLocal = "yyyy/mm/dd"
TWs.Cells(i, 3) = .Cells(zGyo, 5)
TWs.Cells(i, 4) = .Cells(zGyo, 26)
xSg = xSg + TWs.Cells(i, 4)
i = i + 1
Next
End With
DoEvents
Next
.UsedRange.EntireColumn.AutoFit
.UsedRange.Offset(1).Resize(.UsedRange.Rows.Count, 1).NumberFormatLocal = "yyyy/mm/dd"
Wb.Close False
Set TWs = Nothing
Set Wb = Nothing
Set Tb = Nothing
End With
End Sub
Private Sub zFileInitialize02()
Dim zFd As String
Dim zFnm As String
zFd = ThisWorkbook.Path & "\"
zFnm = Dir(zFd & "請求先*.xlsx")
On Error GoTo Errt
Do Until zFnm = ""
Kill zFd & zFnm
zFnm = Dir()
DoEvents
Loop
Exit Sub
Errt:
MsgBox Err.Number & " - " & Err.Description
On Error GoTo 0
MsgBox "請求先ファイルを閉じてからやり直してください"
End
End Sub
Private Sub Pstart02()
With Application
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
End Sub
Private Sub Pend02()
With Application
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
End Sub
（隠居じーさん） 2020/03/19(木) 23:26
こんばんは ＾＾ 例により、ゆーれい変数を削除させて戴きました。m(__)m あっても影響はありません。← と、思います。 (￣▽￣) << _ _ >> （隠居じーさん） 2020/03/19(木) 23:36
いつも丁寧にありがとうございます♪
本日は娘の卒業式でしたので、会社をお休みしておりました…
家でやれればいいのですが、会社のクラウド？の中のファイルなので持ち出せず…
月曜日にさっそくやってみますね^-^
（ri-an） 2020/03/20(金) 00:42
たくさんマクロありがとうございます!(^^)!
私根本がわかってないです。。。
ゆっくりやってみます♪
（ri-an） 2020/03/23(月) 16:57
m(_ _)m （隠居じーさん） 2020/03/23(月) 17:02
上記VBA請求先ごとにBOOKが作られて最高な仕上がりです。
初歩的な質問をさせていただきます。
上記はあくまでダミーであり、こちらの売上帳にコードをのせても中身が反映されません。。。
どこを変更すればよいかいろいろ調べたのですが不明でした。
あと元データが消えてしまうのはなぜでしょうか？？
Delete A B がコードの中にあったのですがそれをなくしても問題はないのでしょうか？？
（ri-an） 2020/03/25(水) 16:03
Workbooks("売上帳【3期分】").Worksheets("R1.5"."R1.6"."R1.7"・・・"R2.4")
をどこかにいれればよいのでしょうか？？
（ri-an） 2020/03/25(水) 16:50
おはよ〜ございます ＾＾ 作成した者ですが。。。２５日は午後からＰＣの無い処へ、外出いたし ておりました。返信がおくれ、すみません。。。何をどぉしたのやら。 。とほほ〜 ＾＾； 既に暗号状態でして。。。いま思い出す努力をし ているところです。纏まりましたら、 ← 【思い出したら】またアッ プ致しますね。ただ現時点で一番最初にアップさせていただいた、ダミ ー情報作成コード、の件ではないのかな〜とは感じています。では後ほど。。。m(_ _)m （隠居じーさん） 2020/03/26(木) 06:56
おはようございます ＾＾
ご質問の内容は実データーを使用しての帳票作成コード Sub zOneInstanceMainNoPivot02()
のテスト実行だと思いますので。
↓ の部分の定数を実情報のブック名に変えて実行して見て下さい。
Private Sub zGetBaseData02()
Const zBnm As String = "A{DF800D74-07CE-4EB5-BD40-6123602D1196}売上帳.xlsx"
Sub zOneInstanceMainNoPivot02() を実行して下さい ダミー情報と実情報の表のフォーマットが同じなら問題なく動くはずです ← 多分 ＾＾； でわ m(_ _)m （隠居じーさん） 2020/03/26(木) 08:04
追 伸
↑のコードは変更せずに
実際の情報のブックをコピーして、ファイル名を
A{DF800D74-07CE-4EB5-BD40-6123602D1196}売上帳.xlsx
に変えてマクロが有るブックと同じフォルダ内に置けば
簡単、安全にテスト出来ると思いますです。
Sub zDummyDataMaker()
は、実行するとA{DF800D74-07CE-4EB5-BD40-6123602D1196}売上帳.xlsx
を削除してダミーに書き換えてしまいますので、実行しないでください
当初情報を共有【内容確認】するためにテスト用として作成しただけ
です。
（隠居じーさん） 2020/03/26(木) 08:16
出来ました＊(^^♪＊
ありがとうございます♪
出来上がった各BookのA列の幅を広げたいのですが、
コードの中に組み込めたりしますか？？
（ri-an） 2020/03/26(木) 10:35
こんにちは ＾＾
Private Sub zMakeCustomerAggregate02()
の
下の方に【シートをコピーしてブックにする手前】
.Range("A:A").ColumnWidth = 15
がありますので ↑ この値を大きくしてください。
集計の合計値等、合ってるか。。。よ〜く確認してくださいね 。。。(￣▽￣)
<< _ _ >>
（隠居じーさん） 2020/03/26(木) 11:11
こんにちは ＾＾ 実際のファイルはなにか13シートある様な無いような事をちらっっと ここでお伺いしたような記憶が有るのですが、大丈夫ですか。。。。 というのも、シートの取り込み制限はやっていません。12シート以上 になると、エラーになるとは思うのですがテストまでできていません。 ご確認を、お願いいたします。 （隠居じーさん） 2020/03/26(木) 12:08
13シートあります！
13シート目は入金確認ですので
反映はしなくていいものです。
いい感じのところまで行くのですが
実行時エラー'13':
型が一致しません
If Month(Gary(i,1)) = zVer2 Then
に黄色のマーカーが付きます。。。
（ri-an） 2020/03/26(木) 12:14
奇数行で色付けをするとなると、また面倒でしょうか？？
1行・・・濃い色で
2行・・・無色
3行・・・薄い色で
4行・・・無色
5行・・・薄い色で
という感じです。
奇数行でも1行目だけ別の色となると？？？です。
（ri-an） 2020/03/26(木) 12:19
こんにちは ＾＾ （ri-an）さん 2020/03/26(木) 12:19 はそう難しくは無いかと思いますので後ほど対応させて戴きます。 シートを12シートに取込の制限をかけますので、差支えなければ 【個人、秘密、機密事項等】教えていただきますとそのまま変更 コードに反映させます、ダミーで良ければ、配列に記述したシート名 を実際の物と書き換えて下さいませ。 （隠居じーさん） 2020/03/26(木) 12:32
【個人、秘密、機密事項等】
とは例えばどんなことでしょうか？？
特に秘密にするものもないのですが。。。笑
（ri-an） 2020/03/26(木) 13:02
こんにちは＾＾。。。
＾＾；恐縮です
ではこちらに
ずら〜〜〜とって
("R1.5"."R1.6"."R1.7"・・・"R2.4")でしたか？
全て半角でしょうか
. は大丈夫だったとは思うのですが、
あとこのお名前は期間によって変化すると予測するのですが
変わるのはR1.5なら 1 の 部分だけでしょうか
（隠居じーさん） 2020/03/26(木) 13:17
それですwww
なのですが、期ごとにファイルを分けているので
５月〜４月に変更しようかと思っています。
なので５月〜
全角数字でお願いいたします。
（ri-an） 2020/03/26(木) 13:32
こんにちは ＾＾ はい！５月〜４月、全角数字了解いたしました。暫し御猶予を m(_ _)m （隠居じーさん） 2020/03/26(木) 13:43
こんばんは ＾＾ ちょっと手こずっています。他にも不都合が発見され ← おい！だいじょうぶか。。。はっ m(_ _)m 多分 テスト反復状態で。。。修正作業を実行中に付き、今 少し、気長にお待ちくださいませ。出来次第ご連絡致 します。<< _ _ >>
（隠居じーさん） 2020/03/26(木) 19:50
隠居じーさんありがとうございます。
いつもすみません。。。。
（ri-an） 2020/03/27(金) 10:07
おはようございます♪
おっしゃる通りです。
本来なら私が考えなければいけないことです。
ここの過去ログを見ながら用語を少しづつ勉強しているところで、まだ組むまでに至っていません。
もう少し努力します。
ご指摘ありがとうございます。
（ri-an） 2020/03/27(金) 10:13
If ws.Name Like "*月" Then
を使うのはダメでしょうか？？
（ri-an） 2020/03/27(金) 11:03
こんにちは ＾＾ りんご さん ありがとうございます。ri-anさんお気遣いありがとうございます。 わたしは､結構、楽しみながら､勉強させて戴いています。半面､りんご さんのご指 摘にもありますように､専門家ではありませんので、思わぬ落とし穴があったり､イレ ギュラーな情報に対した際に改変､改修の必要に迫られた時､かえってご迷惑になる のではとも思いますので最初にお断りさせていただいております｡ですので､このまま お使いに成るのではなく､様々なテストをされて､ご自身で､納得のいく物を作成して いただく過程において､ご勉学の､何かの足しにでもなれば幸甚だと思いアップさせて いただいております。←あまり役には立たないかもですが ＾＾；。。。m(_ _)m
とりあえず､出来ましたのでちょい後でアップしておきますね｡ ただ､処理年月がコードで固定になっています､年間情報から取り込む手もありますが 手入力で指定して､情報確認と表示年月に連動させる方がよいか迷っていましたのでそ のままです｡せっかくダミーも作っていますのでこれ使っていろいろ実験してみて下さい とんでも無い結果が出るかも ← そうでないことをいのってます ＾＾：。。。m(__)m ダミー情報作成のほうも シート名 全角の ５月〜にしておきますね。
＞＞If ws.Name Like "*月" Then ＞＞を使うのはダメでしょうか？？
いえいえ、良いかもしれませんね。(#^.^#)ｖ （隠居じーさん） 2020/03/27(金) 13:16
あまり 公衆の面前にお出しできるようなものでもありませんが。。。（＾◇＾）。。m(_ _)m
Option Explicit
'新規フォルダ（名前は何でも）に新規BOOKにこのコードを貼り付け
'テキトーな名前で【拡張子はxlsmで】保存してから下記コードを実行してください
Private Sub zDummyDataMaker()
Dim zST As Currency
Dim zSCnt As Long
Dim i As Long
Dim Rnum As Long
Dim Tnum As Long
Dim zGyo As Long
Dim zRetu As Long
Dim Snm As String
Dim zDate As Date
Dim zM As Long
Dim WB As Workbook
If Not Dir(ThisWorkbook.Path & "\" & "A{DF800D74-07CE-4EB5-BD40-6123602D1196}売上帳.xlsx") = "" Then
Kill ThisWorkbook.Path & "\" & "A{DF800D74-07CE-4EB5-BD40-6123602D1196}売上帳.xlsx"
End If
WsDeleteA ThisWorkbook
Rnd -3
zDate = DateSerial(2019, 5, 1)
Do
If zM <> Month(zDate) Then
If Snm <> "" Then Worksheets(Snm).UsedRange.EntireColumn.AutoFit
zM = Month(zDate)
zGyo = 1
Snm = StrConv(Trim(zM), vbWide) & "月"
If Not Evaluate("=ISREF(" & Snm & "!A1)") Then
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = Snm
Worksheets(Snm).UsedRange.Clear
End If
With Worksheets(Snm)
.Cells(zGyo, 1).Resize(, 5) = Array("番号", "日付", "現場名", "施工会社", "請求先")
For zRetu = 6 To 23
.Cells(zGyo, zRetu) = "工事内容 - " & Format(zRetu, "00")
Next
.Cells(zGyo, 24) = "金額"
.Cells(zGyo, 25) = "税金"
.Cells(zGyo, 26) = "合計"
For zRetu = 1 To 26
.Range(.Cells(zGyo, zRetu), .Cells(zGyo, zRetu).Offset(2)).Merge
Next
.UsedRange.EntireColumn.AutoFit
End With
End If
With Worksheets(Snm)
Rnum = Int((15 - 3 + 1) * Rnd + 3)
For i = 1 To Rnum
Tnum = Tnum + 1
zGyo = zGyo + 3
.Cells(zGyo, 1) = Tnum
.Cells(zGyo, 2) = zDate
.Cells(zGyo, 3) = "現場名称 - " & Format(Int((10 - 1 + 1) * Rnd + 1), "000")
.Cells(zGyo, 4) = "施工会社 - " & Format(Int((10 - 1 + 1) * Rnd + 1), "000")
.Cells(zGyo, 5) = "請求先 - " & Chr(Int((85 - 65 + 1) * Rnd + 65))
For zRetu = 6 To 23
.Cells(zGyo, zRetu) = "工事内容 - " & .Cells(zGyo, zRetu).Address(0, 0)
Next
.Cells(zGyo, 24).NumberFormatLocal = "#,##0"
.Cells(zGyo, 25).NumberFormatLocal = "#,##0"
.Cells(zGyo, 26).NumberFormatLocal = "#,##0"
.Cells(zGyo, 24) = Int((99999 - 10 + 1) * Rnd + 10) * 100
.Cells(zGyo, 25) = .Cells(zGyo, 24) * 0.1
.Cells(zGyo, 26) = .Cells(zGyo, 24) + .Cells(zGyo, 25)
zSCnt = zSCnt + 1
zST = zST + .Cells(zGyo, 26)
For zRetu = 1 To 26
.Range(.Cells(zGyo, zRetu), .Cells(zGyo, zRetu).Offset(2)).Merge
Next
Next
End With
zDate = zDate + 1
If zDate > DateSerial(2020, 4, 30) Then Exit Do
DoEvents
Loop
Worksheets("Sheet2").Cells(1) = zST
Worksheets("Sheet2").Cells(1, 2) = zSCnt
Worksheets(Snm).UsedRange.EntireColumn.AutoFit
Worksheets.Copy
Set WB = ActiveWorkbook
WB.SaveAs ThisWorkbook.Path & "\" & "A{DF800D74-07CE-4EB5-BD40-6123602D1196}売上帳.xlsx", 51
WsDeleteB WB
WB.Close True
WsDeleteA ThisWorkbook
Set WB = Nothing
End Sub
Private Sub WsDeleteA(ByVal WB As Workbook)
Dim i As Long
Application.DisplayAlerts = False
For i = WB.Worksheets.Count To 1 Step -1
If Sheets(i).Name <> "Sheet1" And _
Sheets(i).Name <> "Sheet2" And _
Sheets(i).Name <> "Sheet3" Then
Sheets(i).Delete
End If
Next
Application.DisplayAlerts = True
End Sub
Private Sub WsDeleteB(ByVal WB As Workbook)
Dim zSnm() As Variant
Dim InvFlg As Boolean
Dim i As Long
Dim Ws As Variant
zSnm = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
Application.DisplayAlerts = False
For i = WB.Worksheets.Count To 1 Step -1
InvFlg = True
For Each Ws In zSnm
If WB.Worksheets(i).Name = StrConv(Trim(Ws), vbWide) & "月" Then
InvFlg = False
Exit For
End If
Next
If InvFlg Then
WB.Worksheets(i).Delete
End If
Next
Application.DisplayAlerts = True
End Sub
とりあえず
仮情報作成グッズです。
（隠居じーさん） 2020/03/27(金) 13:32
ちょい修正分です。。。(￣▽￣)。。。m(_ _)m
Option Explicit
'**********************************************************
'* Pivotを使わない計算版[zOneInstanceMainNoPivot02]
'* 月間集計金額の並びの自由化のためあえてオーソドックスなロジックです
'* 表示月数は１２か月限定、固定、処理対象年月固定
'**********************************************************
'* 開始月金額が無い場合一部空白表示をゼロ表示に修正
'* 罫線とセルの着色追加、
'* 現場別売上金合計の降順でソート追加
'* 作表年月指定、取込年月確認機能追加
'**********************************************************
Sub zOneInstanceMainNoPivot03()
Dim zSymd As Date
Dim zT As Date
zAcceptDate zSymd
zExecuteSelect
zT = Timer
zSheetChk
zFileInitialize
zGetBaseData
Pstart
zMakeCustomerAggregate zSymd
Pend
MsgBox "処理が完了しました " & Format(Timer - zT, "0.0") & " 秒"
End Sub
Private Sub zAcceptDate(ByRef Arg1 As Date)
Dim Tmp As Variant
Tmp = Application.InputBox("開始年と月を入力して下さい", "例 : 20195", "201905", , , , , 1)
If Tmp = False Then End
If MsgBox("処理開始年月確認" & Chr(13) & _
Year(DateSerial(Left(Tmp, 4), Mid(Tmp, 5), 1)) & " 年" & _
Month(DateSerial(Left(Tmp, 4), Mid(Tmp, 5), 1)) & " 月", vbCritical + vbOKCancel) = 2 Then
End
End If
Arg1 = DateSerial(Left(Tmp, 4), Mid(Tmp, 5), 1)
End Sub
Private Sub zSheetChk()
Dim Ws As Worksheet
For Each Ws In ThisWorkbook.Worksheets
If Ws.Name = "TMPXXX" Then
MsgBox "初期化されるシート【 TMPXXX 】が存在します。シート名を変更してください"
End
End If
Next
End Sub
Private Sub zExecuteSelect()
Dim zVar As Variant
zVar = MsgBox("以前に作成した請求先ファイルは削除されます" & Chr(13) & _
"Sheet1 は書き換えられます", vbOKCancel)
If Not zVar = 1 Then
End
End If
End Sub
Private Sub zMakeCustomerAggregate(ByVal zSymd As Date)
'表示される月は１２ヶ月固定です
Dim i As Long
Dim j As Long
Dim zY As Long
Dim zVar As Variant
Dim zVar2 As Variant
Dim zR As Range
Dim zRR As Range
Dim zD As Object
Dim Snm As String
Dim Bary() As Variant
Dim Gary() As Variant
Dim zBox() As Currency
Dim zDic() As Currency
Dim MasT As Object
Dim MasG As Object
Set MasT = CreateObject("Scripting.Dictionary")
Set zD = CreateObject("Scripting.Dictionary")
Set MasG = CreateObject("Scripting.Dictionary")
For i = 1 To 12 '表示用月マスタ作成
zD(Month(DateAdd("m", i - 1, zSymd))) = DateAdd("m", i - 1, zSymd)
Next
With Worksheets("Sheet1")
Bary = .Cells(1).CurrentRegion.Value
'得意先マスタ作成
For i = 2 To UBound(Bary, 1)
MasT(Bary(i, 3)) = Empty
DoEvents
Next
End With
Snm = "TMPXXX"
If Not Evaluate("=ISREF(" & Snm & "!A1)") Then Sheets.Add.Name = Snm
With Worksheets(Snm)
For Each zVar In MasT '得意先毎ループ
.Activate
.Cells.Delete
.Cells(1).Resize(UBound(Bary, 1), UBound(Bary, 2)) = Bary
.Cells(1, "K") = Bary(1, 3)
.Cells(2, "K") = zVar
.Cells(1).CurrentRegion.AdvancedFilter xlFilterCopy, .Range("K1:K2"), .Range("M1"), False
.Range("A:L").Delete
Gary = .Cells(1).CurrentRegion.Value '抽出された得意先限定情報格納
'得意先限定情報を最初から最後まで処理
For i = 2 To UBound(Gary, 1)
ReDim zBox(1 To zD.Count) '日別売上金取得用12か月分配列初期化
j = 0
'日毎売上から年月を判定後、月別配列へ一時格納
For Each zVar2 In zD
j = j + 1
If Month(Gary(i, 1)) = zVar2 And Year(zD(zVar2)) = Year(Gary(i, 1)) Then
zBox(j) = Gary(i, 4)
Exit For
End If
Next
'現場マスタ作成と加算処理同期
If Not MasG.Exists(Gary(i, 2)) Then
MasG(Gary(i, 2)) = zBox
Else
zDic = MasG(Gary(i, 2))
For j = LBound(zDic) To UBound(zDic)
zDic(j) = zDic(j) + zBox(j)
Next
MasG(Gary(i, 2)) = zDic
Erase zDic
End If
Application.StatusBar = Space$(5) & zVar & " を処理中 " & i & " 件目"
DoEvents
Next
.Cells(1, 11).Resize(1, UBound(zD.items) + 1) = zD.items
.Cells(1, 11).Resize(1, UBound(zD.items) + 1).NumberFormatLocal = "yyyy - mm"
zY = 2
For Each zVar2 In MasG
.Cells(zY, 10) = zVar2
For i = LBound(MasG(zVar2)) To UBound(MasG(zVar2))
.Cells(zY, 10 + i) = MasG(zVar2)(i)
Next
zY = zY + 1
Next
.Cells(1, 10) = zVar
Set zR = .Cells(1, 10).CurrentRegion
zR.Offset(1, 1).NumberFormatLocal = "#,##0"
With zR(1).Offset(zR.Rows.Count, 1).Resize(, zR.Columns.Count - 1)
.Formula = "=sum(r[-" & zR.Rows.Count - 1 & "]c:r[-1]c)"
.Value = .Value
End With
With zR(zR.Columns.Count).Offset(1, 1).Resize(zR.Rows.Count, 1)
.Formula = "=sum(rc[-" & zR.Columns.Count - 1 & "]:rc[-1])"
.Value = .Value
End With
zR(1).Offset(zR.Rows.Count) = "合 計"
zR(1).Offset(, zR.Columns.Count) = " 総 合 計"
.UsedRange.ColumnWidth = 12.5
.Range("A:I").Delete
.Range("A:A").ColumnWidth = 15
Set zR = .Cells(1).CurrentRegion
Set zR = zR.Resize(zR.Rows.Count - 1, zR.Columns.Count)
zR.Sort Key1:=zR.Columns(zR.Columns.Count), Order1:=xlDescending, Header:=xlYes
MasG.RemoveAll
zMakeCustomerAggregateSubCellsColorSet Snm
.Copy
ActiveWorkbook.Worksheets(1).Name = zVar
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & zVar & ".xlsx", 51
ActiveWorkbook.Close False
DoEvents
Next
End With
Worksheets(Snm).Delete
Worksheets("Sheet1").Activate
Erase Bary, zBox
Set MasT = Nothing
Set MasG = Nothing
Set zD = Nothing
Set zR = Nothing
Set zRR = Nothing
Application.StatusBar = False
End Sub
Private Sub zMakeCustomerAggregateSubCellsColorSet(ByVal Snm As String)
Dim i As Long
Dim rr As Range
With Worksheets(Snm)
Set rr = .Cells(1).CurrentRegion
.UsedRange.Interior.Color = xlNone
rr.Borders.LineStyle = True
For i = 1 To rr.Rows.Count
If Not i Mod 2 = 0 And i > 1 Then
Intersect(rr(i, 1).EntireRow, rr).Interior.Color = RGB(255, 255, 200)
End If
If i = 1 Or i = rr.Rows.Count Then
Intersect(rr(i, 1).EntireRow, rr).Interior.Color = RGB(200, 200, 200)
End If
Next
End With
Set rr = Nothing
End Sub
Private Function zGetBaseDataWsChk(ByVal WB As Workbook) As String
Dim i As Long
Dim zVar As Variant
Dim zWsFlg() As Long
Dim TmpStr As String
Dim zRWs As Variant
zRWs = Array("５月", "６月", "７月", "８月", "９月", _
"１０月", "１１月", "１２月", "１月", "２月", "３月", "４月")
ReDim zWsFlg(1 To UBound(zRWs) + 1)
For Each zVar In WB.Worksheets
For i = 0 To UBound(zRWs)
If zVar.Name = zRWs(i) Then
zWsFlg(i + 1) = 1
End If
Next
Next
For i = LBound(zWsFlg) To UBound(zWsFlg)
If zWsFlg(i) = 1 Then
TmpStr = TmpStr & zRWs(i - 1) & Chr(13)
End If
Next
zGetBaseDataWsChk = TmpStr
Erase zRWs, zWsFlg
End Function
Private Sub zGetBaseData()
Const zBnm As String = "A{DF800D74-07CE-4EB5-BD40-6123602D1196}売上帳.xlsx"
Dim i As Long
Dim j As Long
Dim xSg As Currency
Dim Tb As Workbook
Dim TWs As Worksheet
Dim WB As Workbook
Dim zGyo As Long
Dim zRWs As Variant
Dim Snm As String
Dim zWsFlg(1 To 12) As Long
Set Tb = ThisWorkbook
If Dir(Tb.Path & "\" & zBnm) = zBnm Then
Set WB = Workbooks.Open(Tb.Path & "\" & zBnm)
Snm = zGetBaseDataWsChk(WB)
If Len(Snm) = 0 Then
WB.Close False
Set Tb = Nothing
Set WB = Nothing
MsgBox "売上情報が存在しません、終了します"
End
Else
zRWs = Split(Snm, Chr(13))
End If
Else
Set Tb = Nothing
MsgBox "売上帳ファイルが有りません", vbCritical
End
End If
Set TWs = Tb.Worksheets("Sheet1")
With TWs
.UsedRange.Clear
.Cells(1).Resize(, 4) = Array("日付", "現場名", "請求先", "合計")
i = 2
For j = LBound(zRWs) To UBound(zRWs)
If zRWs(j) <> "" Then
With WB.Worksheets(zRWs(j))
.Activate
For zGyo = 4 To .Cells(.Rows.Count, 2).End(xlUp).Row + 1 Step 3
TWs.Cells(i, 1) = .Cells(zGyo, 2)
TWs.Cells(i, 2) = .Cells(zGyo, 3)
TWs.Cells(i, 2).NumberFormatLocal = "yyyy/mm/dd"
TWs.Cells(i, 3) = .Cells(zGyo, 5)
TWs.Cells(i, 4) = .Cells(zGyo, 26)
xSg = xSg + TWs.Cells(i, 4)
i = i + 1
Next
End With
End If
DoEvents
Next
.UsedRange.EntireColumn.AutoFit
.UsedRange.Offset(1).Resize(.UsedRange.Rows.Count, 1).NumberFormatLocal = "yyyy/mm/dd"
WB.Close False
Set TWs = Nothing
Set WB = Nothing
Set Tb = Nothing
Erase zRWs
End With
End Sub
Private Sub zFileInitialize()
Dim zFd As String
Dim zFnm As String
zFd = ThisWorkbook.Path & "\"
zFnm = Dir(zFd & "請求先*.xlsx")
On Error GoTo Errt
Do Until zFnm = ""
Kill zFd & zFnm
zFnm = Dir()
DoEvents
Loop
Exit Sub
Errt:
MsgBox Err.Number & " - " & Err.Description
On Error GoTo 0
MsgBox "請求先ファイルを閉じてからやり直してください"
End
End Sub
Private Sub Pstart()
With Application
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
End Sub
Private Sub Pend()
With Application
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
End Sub
新規機能追加＆間違い探し。あれば。。。今の内。。。
ま、暫く死にゃしないとはおもいますが。。。←隠居じーさんの話。。(#^.^#)
（隠居じーさん） 2020/03/27(金) 13:43
↑だと実行できなかったので
＜Private Sub zDummyDataMaker()
↑
をなくしSub zDummyDataMaker()にしました。
これはなんとなくですｗｗｗ
これでなんと実行できてしまったので、ご報告までに。
・出来上がった長い名前のファイルは８月まで作成されました。
・新規Bookのsheet2にA1[4806472770]、B1[848]と入力されました。
（ri-an） 2020/03/27(金) 14:01
こんにちは ＾＾ リボンの開発 → マクロ からですと表示されませんね。外していただくと表示されます。 上部にある日付を変えて色んな情報を作りテストしてみて下さい。
sheet2は 作成された合計金額、と総件数です。日付期間を変えなければ何回実行しても 同じ金額になりますよ。 あとで、集計済のＢＯＯＫの縦横合計の検算用に取り込んでおきました。 簡単集計マクロでも練習がてらお作りになって合っているか確認でもして下さい うまく応用、作成できれば本番情報の検算にも使えなくは無いかもです。 （隠居じーさん） 2020/03/27(金) 14:15
配色見やすく思っているものができました!(^^)!
あとは縦の合計の昇順をつけたいと思っております♪
調べてみます。
コードができたとしても、どこに組み込むかなどがまだ分からないので
また質問させて下さいm(__)m
（ri-an） 2020/03/27(金) 14:23
こんにちは ＾＾ 先ほどもお知らせいたしましたが、このままでは今期[201905〜202004]しか 使えないと思います、その都度コード内の日付を変えるなら別ですが、。。 一度、未来の情報も作ってテストしてみてくださいませ。 入力メッセージ出して入力出来るように、した方が便利かと思っております。 いや〜なにせ慌てて書いたもので ← 言い訳。。。m(_ _)m 汎用性が著しく 低下したコードになっておりますです。新しいコードが出来たら教えて下さい。 その時に間に合うように、もし、よろしければ、これだけ変更しておきます。 （隠居じーさん） 2020/03/27(金) 14:44
の日付を期が変わるごとに手作業で変更ということですね？？
私も思いましたが、変更できる能力はまだまだ身についてません。。。m(__)m
『昇順』を列で行おうとすると、N列(総合計)○行(合計)のセルの値が一番大きくなるのでそれが上に来ちゃいますよね？？
かといって、現場名の数もBookによって違うので、指定もできず。。。
頑張って探しますｗｗｗ
（ri-an） 2020/03/27(金) 15:13
こんばんは ＾＾ 任意の列をキーにして全ての列が並び変わってくると思いますが どうなれば正解なのでしょうか。売上順に並び替えをご希望なら 総合計出す前に現場別合計で並び替えるとかでしょうか。それと ダミー情報作成が一部間違っていました。上のコードを修正して おきますね。vba Sortとかで検索してみるとたくさんサンプル 等がありますよ。あとコードのここかな？と思う手前にStopを 書込んでおくとそこでコードが中断されます。Ｆ８で１ステップ 【行】毎に実行できますので、ローカルウインドウ等で変数の 値等、確認できますよ。Ｆ５キーと使い分けると大変便利です。 ブレークポイントでも同じですね。 Pstart02 設定を中止 Pend02 設定を開始 は処理速度アップ用なので、デバッグ時は止めておくと解りやす いかと思います。 （隠居じーさん） 2020/03/27(金) 16:30
Sort出てきました！
あとxlascending
1Bookごと年間売上順に昇順なので、総合計を出す前になります。
Stop使ってみます(^^♪
ありがとうございます(#^^#)
（ri-an） 2020/03/27(金) 16:55
こんばんは ＾＾ よかったですね （＾◇＾）ｖ あと、大きなお世話かもしれませんが。。。 年間情報は普通、セルの結合はせず処理単位で１行毎にしておけば、要するに テーブル型式といいますか、データーベースライクにという風にし、保存シート名も 201902、201903、〜のようなシート名にしておけばおのずと１２か月分と云う範囲は気にせず 柔軟に、年度形式が変わっても「決算年度、半期」「所得税用年度」「住民税用」とか2,3年分 保持しておけば何にでも柔軟に対応が出来、とても手間が省けるように思います。見た目が悪 ければそこから今の年間情報みたいな作表をする方が何かと便利なように、思うのですが、気 のせいでしょうか。。。でもいろいろ、諸般の事情みたいなのが有るのですよね。＾＾； 老人の独り言でした、でわでわ、頑張ってくださいね (#^.^#)ｖ （隠居じーさん） 2020/03/27(金) 17:37
追伸 ＾＾/ 期間指定の件、出来次第またアップしておきます。 老人の為しばし御猶予を。。。(◎_◎;) ← また言い訳 。。。m(_ _)m （隠居じーさん） 2020/03/27(金) 17:46
Private Sub zGetBaseData02()
TWs.Cells(i, 1) = .Cells(zGyo, 2)
じゃない気がするんですが、再度確認した方が良いと思います。
＞Ｂ：日付（まとめる際必要ない）
＞（ri-an） 2020/03/17(火) 15:37
（kazuo） 2020/03/27(金) 18:11
kazuoさん ありがとうございます。 確認致します。 取り急ぎ御礼まで。。。m(_ _)m （隠居じーさん） 2020/03/27(金) 18:45
こんばんは ＾＾ kazuoさん へ 他にも方法は有るのかもしれませんが、月別に集計時、月の仕訳に 使用するため取り込んでおりました、貴重なご意見、感謝いたして おります。また御気づきの点、不審な箇所等、御座いましたら、宜 しくお願い致します。ご報告まで m(_ _)m （隠居じーさん） 2020/03/27(金) 19:10
ここ数日間当サイトの全文検索でいろいろ見ていますが
1行ごとのテーブル型式の内容で質問されている方がすごく多いですね。。。
削除していただいた工事内容部分が3行データになっており、あとは1行で入力できるんですｗｗｗ
なんとかしないとダメですね(-_-;)
（ri-an） 2020/03/28(土) 09:03
おはようございます ＾＾ ダメという事もないとおもいますが使うのにひと手間多くかかるというう事ですかね 可能でしたら、3行分、3列増やすことでカバーするとか、ま予備に5列とか10列確保 しておくのも一手かと。。。工事内容1、工事内容2 〜 みたいな m(_ _)m 只今更新中。。。 ← どこかで見たような。。。後ほど、また （隠居じーさん） 2020/03/28(土) 10:37
こんにちは ＾＾ おまたせ致しました。 （隠居じーさん） 2020/03/27(金) 13:43 のコードを 貼り換えておきました。プロシジャー名等改名、追加等、御座いますので以前の物は 消去【ri-anさんの変更箇所はバックアップをお取りの上、書き戻してください】して 新規の物と入れ替えて下さい。尚、ソートは以前からありましたので、売上の多い方 から並び替えに変更しています。ろくにテストはしていませんので、金額、その他等、 ご確認の程、そちらで、お願いいたします。 （隠居じーさん） 2020/03/28(土) 14:25
隠居じーさんなにからなにまでお世話かけましたm(__)m
当初の希望通りのものができあがりました☆
工事内容を列に伸ばすスタイルに変更したときも、作成していただいたコードを元に
検索して調べ学習していきます。
本当にありがとうございました。
（ri-an） 2020/03/31(火) 11:48
こんにちは ＾＾ 恐縮で御座います。 m(_ _)m （隠居じーさん） 2020/03/31(火) 12:34
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.