[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『Vlookupの参照範囲を最終行まで』（miffy）
Exel2003,WindowsXP
Sheet1のA4セルからF列最終行までデータを入力し（行は毎日増えていく） Sheet2のG5セルに条件に合致した数値を表示したいのですが、 標準モジュールに
Function MyVlookup(検索値, 範囲, 列) On Error GoTo エラー処理 MyVlookup = WorksheetFunction.VLookup(検索値, 範囲, 列, False) Exit Function エラー処理: MyVlookup = "" End Function
と入力してあり、Sheet2のG5セルに =MyVlookup(A1,sheet1!$A$4:$F$10,6) と入力してあります。
これだとF列10行までしか参照できないので、最終行まで参照するにはどうしたら 良いでしょうか。
範囲を「sheet1!$A$4:$F$10」と4行目から10行めに指定しているのだから当然では？ そこを最終行までの指定にするだけですよ。
=MyVlookup(A1,sheet1!$A$4:$F$65536,6)
あと、これでもいいかな？
Function MyVlookup(検索値, 範囲, 列)
On Error Resume Next
MyVlookup = ""
MyVlookup = WorksheetFunction.VLookup(検索値, 範囲, 列, False)
On Error GoTo 0
End Function
(独覚)
65536行までしかないのですね...知りませんでした。 下のやり方で指定する場合（その方が処理が早い,もしくはデータが軽いでしょうか？ G5セルの内容を3万箇所くらいコピーして使いたいです）、G5セルの式の参照範囲は どのように入力すればよいでしょうか？ (miffy)
>G5セルの内容を3万箇所くらいコピーして使いたいです どういう内容でしょうか? ユーザー定義関数じゃないとだめなの? 普通のVLOOKUP関数でも良いような感じですが?
最終行が、A列の最終行で良ければ、 Function MyVlookup(検索値, 範囲, 列)
On Error GoTo エラー処理
Set 範囲 = Sheets("Sheet1").Range(Range("A4"), Cells(Rows.Count, 1).End(xlUp)).Resize(, 6)
MyVlookup = WorksheetFunction.VLookup(検索値, 範囲, 列, False)
Exit Function
エラー処理:
MyVlookup = ""
End Function
で、
G5=MyVlookup(I5,範囲,4) とか?
(kei)
同じようなものですけど、Sheet2のG5セル =MyVlookup(A1,sheet1!$A$4,6)
Function MyVlookup(検索値 As Variant, 範囲先頭セル As Range, 列 As Long)
Dim r As Range
On Error Resume Next
With 範囲先頭セル.Parent
Set r = .Range(範囲先頭セル, _
.Cells(.Rows.Count, 範囲先頭セル.Column).End(xlUp)).Resize(, 列)
MyVlookup = ""
MyVlookup = WorksheetFunction.VLookup(検索値, r, 列, False)
End With
On Error GoTo 0
End Function
3万箇所にこんな関数入れたら重たくて仕方ないですよね。 何か別の方法考えた方がいいかも。
（ウッシ）
Sheet2がどうなっているかわからないので、完全な参考コードですけど こんな感じで全部VBAで処理してしまったほうが早いんじゃないかと思います。
Private Sub Worksheet_Activate()
Dim dat() As Variant, tbl As Variant
Dim i As Long
tbl = Worksheets("Sheet1").Range("A1").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(tbl)
If Not .Exists(tbl(i, 1)) Then
.Add tbl(i, 1), tbl(i, 6)
End If
Next i
tbl = Worksheets("Sheet2").Range("A1").CurrentRegion.Value
ReDim dat(1 To UBound(tbl), 1 To 1)
For i = 1 To UBound(tbl)
dat(i, 1) = .Item(tbl(i, 1))
Next i
End With
Worksheets("Sheet2").Range("G5").Resize(UBound(dat)).Value = dat
End Sub
（ｍｏｍｏ）
ウッシさんの方法で解決したつもりだったのですが、なぜかsheet1の内容を変更（行追加） したらsheet2のG5セルが自動で変更されず、G5の計算式が表示される所をクリックしてEnterを 押すと変更されます（・・・？）。 ツール-オプション-計算方法-シート再計算をクリックしても変更しません（するならその操作を マクロ登録しようかとも思ったのですが）。
momoさんの作ってくださったマクロが勉強不足でよくわからないのですが、
一応sheet2の構造は、
A B C D E F G H I・・・
番号（条件1） 情報1 情報2 情報3 情報4 （条件2） 4月 5月 6月
(5行目) No.1 100 200 300
No.2 200 300 400
No.3 300 400 500
のような感じで番号は750件続き（4月の100などは今回自動で出したい金額。4月のvlookupの検索値は
A5&"-"&F5&"-"&4&"-"&"○○費"）、
sheet1はA4セルに=B4&"-"&D4&"-"&C4&"-"&E4と入っていて A B（番号） C（月） D E（○○費） F (4行目）上記式 条件1 条件2 条件3 条件4 金額 で5行目以下は毎日多数追加されていくというものです。 （sheet2は○○費、sheet3は○○費・・・で費は24費目有り。）
なんとなく伝わりますでしょうか・・・ (miffy)
Function MyVlookup(検索値 As Variant, 範囲先頭セル As Range, 列 As Long)
' ↓これを追加して試して下さい。
Application.Volatile
Dim r As Range
On Error Resume Next
MyVlookup = ""
With 範囲先頭セル.Parent
Set r = .Range(範囲先頭セル, _
.Cells(.Rows.Count, 範囲先頭セル.Column).End(xlUp)).Resize(, 列)
MyVlookup = WorksheetFunction.VLookup(検索値, r, 列, False)
End With
On Error GoTo 0
End Function
（ウッシ）
４月～６月などあるのですね。だとするとSheet1も？ データの中身がわからないので、いまいちピンときませんね。
得たい数値はユニークなものですか？ それとも同じ条件が複数あって集計でしょうか
１費目１シートという事は２４シートに同じものが？
いずれにしてもVLOOKUPでは、再計算に相当かかりますね。 ユーザー定義関数ならなおさら・・・・ （ｍｏｍｏ）
＞ウッシさん 出来ました！！感動です。 ＞momoさん 月は12月まであり、sheet1にはデータを毎日数行追加していくだけなのですが C列には4月が入ったり12月が入ったりします。Dの条件は2種類で、E列に入れる24費目 （これもＡ費だったりＢ費だったり）がそれぞれsheet2と同じ形式で24sheet必要で （要するにE列の費目ごとのsheetが必要）全24sheetにNoが750（人を特定する番号） 必要です。 sheet2のG5セルの式をコピーする必要があるセルが、 No750人×12ヶ月×24費目(sheet)×2（D列の二種類ごと）＝432,000箇所でした。 （上記の3万箇所は大変大きな計算ミスでした） これまでbookもバラバラでほぼ手計算なので膨大な労働時間を要しています。 システム化すれば1000分の1くらいの労力で済むと思っているのですが、 心が折れそうな感じです・・・ なんとなく出来上がりが見えつつあるので、式のコピー（オートフィル）と データ入力用のフォームを作れば、あとは処理速度がどうかと思うのですが・・・
なんとなくですが作ってみました。 ブックをコピーして試してください。
Sheet1はそのままSheet1として ○○費のシートは、シート名が○○費になっているものとします。
Sub test()
Dim i As Long, j As Long, k As Long
Dim dat As Variant, tbl As Variant, buf As Variant, myMonth As Variant, myKey As Variant
Dim myR As Range
With Worksheets("Sheet1")
With .Columns("A:F")
Set myR = .Find("*", .Cells(1), xlValues, xlPart, xlByRows, xlPrevious, False, False, False)
End With
tbl = .Range(.Range("A4"), myR.EntireRow.Columns("F")).Value
End With
myMonth = Array(4, 5, 6, 7, 8, 9, 10, 11, 12, 1, 2, 3)
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(tbl)
If Not .Exists(tbl(i, 5)) Then
Set .Item(tbl(i, 5)) = CreateObject("Scripting.Dictionary")
End If
With .Item(tbl(i, 5))
dat = .Item(tbl(i, 2))
If IsArray(dat) = False Then ReDim dat(1 To 12)
dat(Application.WorksheetFunction.Match(tbl(i, 3), myMonth, 0)) = tbl(i, 6)
.Item(tbl(i, 2)) = dat
End With
Next i
myKey = .Keys
For i = 0 To UBound(myKey)
With Worksheets(myKey(i))
tbl = .Range(.Range("A5"), .Range("A5").End(xlDown)).Value
End With
ReDim dat(1 To UBound(tbl), 1 To 12)
For j = 1 To UBound(tbl)
buf = .Item(myKey(i)).Item(tbl(j, 1))
If IsArray(buf) Then
For k = 1 To 12
dat(j, k) = buf(k)
Next k
End If
Next j
Worksheets(myKey(i)).Range("G5").Resize(UBound(tbl), 12).Value = dat
Next i
End With
End Sub
単独で実行してみて大丈夫ならボタンにでもイベントにでも登録してください。 時間はさほど掛からないと思いますが。
一応、サンプルデータとしてSheet1に３万件のデータ（ランダム）で 24費目、750名分のIDを用意してテストしたところ、全データ処理時間は1.39秒でした。
（ｍｏｍｏ）
取り急ぎ･･･本当にありがとうございます！ これから検証してみます。我が社からmomoさんに中元を贈りたいとか momoさんの属性（私は理工学系院生に賭けました！）について朝から盛り上がっています。 (miffy)
･･･すみません、前提として、sheet2以下24費目分のsheetは予め作っておくのでしょうか。 sheet1のみデータを入力して他のsheetは作らずマクロを実行したところ、 「実行時エラー'1004': WorksheetFunctionクラスのMatchプロパティを取得できません」とメッセージが出て、 コードの上から20行目のdat(Application.WorksheetFunction.Match.....のところが黄色くなります。
･･･ここまで作っていただいたのでこれで出来たらあとは考えなければと思っていたのですが・・・ 実は、sheet2の表は正確にはsheet1のD4の2種ごとに二段づつにしてあるのです･･･
sheet2 A列(番号) B列(情報1) C列(情報2) D列(情報3) E列(情報4) F列(種) G列(4月) H列(5月) ・・・ K列(4～7月計) L列(8月) ・・・ Q列(8～12月計) ・・・ U列(1～3月計)V列(合計) (5行目) A5:1001 B5:(1001の情報1) ・・・ F5:一種 G5:(=A5&"-"&F5&"-"&4&"-"&"○○費") F5:(=A5&"-"&F5&"-"&5&"-"○○費")・・・ (6行目) A6:1001（白色）B6:(空白) ・・・ F6:二種 G6:(=A6&"-"&F6&"-"&4&"-"&"○○費") F6:(=A6&"-"&F6&"-"&5&"-"○○費")・・・ (7行目) A7:1002 B7:(1002の情報1) ・・・ F7:一種 G7:(=A7&"-"&F7&"-"&4&"-"&"○○費") F7:(=A7&"-"&F7&"-"&5&"-"○○費")・・・ (8行目) A8:1002（白色）B8:(空白) ・・・ F8:二種 G8:(=A8&"-"&F8&"-"&4&"-"&"○○費") F8:(=A8&"-"&F8&"-"&5&"-"○○費")・・・ ↓ (1503行目)A1503:5150 B1503:(5150の情報1) ・・・ F1503:一種 G1503:(=A1503&"-"&F1503&"-"&4&"-"&"○○費") F1503:(=A1503&"-"&F1503&"-"&5&"-"○○費")・・・
A列の番号は1001～1150と2001～2150と3001～3150と4001～4150と5001～5150の計750人となっていて、 人が5種類150人ずつを最大と見ている（今後増えて1種類150人を超える所属が出るのが懸案事項。 今年度については全約30所属で1種類150人未満なので150人までで作った。少ない所属は1種類10人程度 のところもある）のです。
(miffy)
属性は水系で雷に弱いです。 エクセルは仕事で使いますがVBAは単なる趣味です。
それは置いといて、シートの構成が少しわかってきましたので再度作り直してみます。 ちなみに、現状はSheet2以降は雛形が出来ている前提です。 少し時間をください。 （ｍｏｍｏ）
情報１～４をどうするのかわかりませんが とりあえずSheet1のデータだけがある状態で以下のコードを試してみてください。
'================================================================================
Const MaxSyu As Long = 5 '種別数 Const MaxNin As Long = 150 '種別毎の人数
Sub test()
Dim i As Long, j As Long, k As Long, co As Long
Dim dat As Variant, tbl As Variant, buf As Variant, myMonth As Variant, myKey As Variant
Dim myR As Range
Application.ScreenUpdating = False
With Worksheets("Sheet1")
With .Columns("A:F")
Set myR = .Find("*", .Cells(1), xlValues, xlPart, xlByRows, xlPrevious, False, False, False)
End With
tbl = .Range(.Range("A4"), myR.EntireRow.Columns("F")).Value
End With
myMonth = Array(4, 5, 6, 7, 8, 9, 10, 11, 12, 1, 2, 3)
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(tbl)
If Not .Exists(tbl(i, 5)) Then
Set .Item(tbl(i, 5)) = CreateObject("Scripting.Dictionary")
End If
With .Item(tbl(i, 5))
dat = .Item(tbl(i, 2) & vbTab & tbl(i, 4))
If IsArray(dat) = False Then ReDim dat(1 To 12)
dat(Application.WorksheetFunction.Match(tbl(i, 3), myMonth, 0)) = tbl(i, 6)
.Item(tbl(i, 2) & vbTab & tbl(i, 4)) = dat
End With
Next i
myKey = .Keys
ReDim DatBase(1 To MaxSyu * MaxNin * 2, 1 To 18)
co = 0
For i = 1 To MaxSyu
For j = 1 To MaxNin
For k = 1 To 2
DatBase(co + k, 1) = i * 1000 + j
DatBase(co + k, 6) = Choose(k, "一種", "二種")
Next k
co = co + 2
Next j
Next i
For i = 0 To UBound(myKey)
dat = DatBase
For j = 1 To UBound(dat)
buf = .Item(myKey(i)).Item(dat(j, 1) & vbTab & dat(j, 6))
If IsArray(buf) Then
For k = 1 To 12
dat(j, k + 6) = buf(k)
Next k
End If
Next j
With Worksheets.Add(After:=Worksheets(Worksheets.Count))
.Name = myKey(i)
.Range("A4:R4").Value = Array("番号", "情報1", "情報2", "情報3", "情報4", "種", _
"4月", "5月", "6月", "7月", "8月", "9月", "10月", "11月", "12月", "1月", "2月", "3月")
.Range("A5").Resize(UBound(dat), 18).Value = dat
End With
Next i
End With
Worksheets("Sheet1").Select
Application.ScreenUpdating = True
MsgBox "完了"
End Sub
'================================================================================
（ｍｏｍｏ）
趣味・・・とは冗談ですよね。 もう本当にすごいですし、お仕事をされているならなおさら申し訳ないです・・・
エラーメッセージが出てしまうのですが・・・ 「コンパイルエラー:定義式が必要です。」コードの上から28行目のMaxSyuが選択状態になります。
・・・情報について、も申し上げるのが本当に申し訳ないのですが・・一応・・ 「基本情報」というsheet名で (2行目) A列(番号) B列(情報1) C列(情報2) ・・・・ S列(情報18) (3行目) A3:1001 B3:(1001の情報1) C3:(1001の情報2) ・・・ S3:(1001の情報18) (4行目) A4:1002 B4:(1002の情報2) C4:(1002の情報2) ・・・ S4:(1002の情報18) この基本情報もsheet1と同様にmenuシートのボタン→ユーザーフォーム表示→入力させて 最終行に追加していく形にしようと思っています（予め750行用意しておくより良いかなと 思っただけなので費目sheetのように人数分表を作っておいても構いません。年度を通して基本情報は変わらないので・・・）
費目シート(sheet2～sheet25)では A列(番号) B列(情報1) C列(情報2) D列(情報3) E列(情報4) A5:1001 B5:(1001の情報1 =MyVlookup(A5,基本情報!$A$",2)と入力) C5:(1001の情報2 =MyVlookup(A5,基本情報!$A$",3)と入力) D5:(1001の情報3）E5:(1001の情報4)
となっています。 (miffy)
とりあえず、大枠がうごかないとなので・・・ >Const MaxSyu As Long = 5 '種別数 >Const MaxNin As Long = 150 '種別毎の人数
この2行は最初に入っていますか？ （ｍｏｍｏ）
もう一度確認したいのですが、 「とりあえずSheet1のデータだけがある状態で以下のコードを試してみてください。」 というのは、Sheet1のみ作成し、他のsheetは作らなくて良いですか？それともSheet2以下の 雛形を作っておくのでしょうか・・・？
Sheet1のみ作って実行すると・・なぜか先ほどと違うエラーが出ます。 >Const・・からの2行は最初に入っています。
「実行時エラー'1004': WorksheetFunctionクラスのMatchプロパティを取得できません」で コードの上から23行目の dat(Application.WorksheetFunction.Match(tbl(i, 3), myMonth, 0)) = tbl(i, 6) が黄色くなります。 (miffy)
Sheet1だけで、他のシートは必要ありません。
Sheet1のC列には月が数字として入っているのではないのですか？
>myMonth = Array(4, 5, 6, 7, 8, 9, 10, 11, 12, 1, 2, 3) の部分を
myMonth = Array("4月", "5月", "6月", "7月", "8月", "9月", "10月", "11月", "12月", "1月", "2月", "3月")
とか
myMonth = Array("4", "5", "6", "7", "8", "9", "10", "11", "12", "1", "2", "3")
にするとどうでしょう？ （ｍｏｍｏ）
ちょっと、色々回答すると混乱してしまうと思いますので、時間の空いたときにでも試して下さい、
新規ブックで、
Sub jyunbi_Sheet1()
With Worksheets("Sheet1")
.Range("B3:F3").Value = Array("番号", "月", "種", "費", "金額")
End With
End Sub
Sub jyunbi_費目シート雛形Sheet2()
Dim h As Long
Dim i As Long
Dim j As Long
Dim k As Long
With Worksheets("Sheet2")
For k = 0 To 4
h = k * 300 + 5
i = k * 1000 + 1000
For j = 0 To 149
.Cells(h + j, 1) = i + j + 1
.Cells(h + j + 1, 1) = i + j + 1
.Cells(h + j, "F") = "一種"
.Cells(h + j + 1, "F") = "二種"
h = h + 1
Next
Next
.Range("A4:R4").Value = Array("番号", "情報1", "情報2", "情報3", "情報4", "種", _
"4", "5", "6", "7", "8", "9", "10", "11", "12", "1", "2", "3")
.Range("G4:R4").NumberFormatLocal = "#""月"""
End With
End Sub
Sub jyunbi_基本()
Dim h As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim s As Worksheet
On Error Resume Next
Set s = Worksheets("基本情報")
If s Is Nothing Then
Set s = Worksheets.Add(Worksheets("Sheet1"))
s.Name = "基本情報"
End If
On Error GoTo 0
With s
.Range("A2").Value = "番号"
.Range("B2").Value = "情報1"
.Range("B2").AutoFill Destination:=.Range("B2:S2"), Type:=xlFillDefault
For k = 0 To 4
h = k * 150 + 3
i = k * 1000 + 1000
For j = 0 To 149
.Cells(h + j, 1) = i + j + 1
Next
Next
End With
End Sub
Sub jynbi_費目シート()
Dim i As Long
For i = 1 To 24
Worksheets("Sheet2").Copy After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = Chr(64 + i) & "費"
Next
End Sub
ここまでを順番に実行して下さい。
その後に、
Sheet1のシートモジュールに、
Private Sub Worksheet_Change(ByVal Target As Range)
Dim e As Long
Dim m As Long
Dim r As Range
Dim t As Range
Dim v As Variant
Dim sh As Worksheet
e = Range("F" & Rows.Count).End(xlUp).Row
If e <= 3 Then Exit Sub
Set t = Intersect(Target, Range("F4:F" & e))
If t Is Nothing Then Exit Sub
For Each r In t
With r.EntireRow
If WorksheetFunction.CountA(.Cells(1, "B").Resize(, 4)) = 4 Then
On Error Resume Next
Set sh = Worksheets(CStr(.Cells(1, "E")))
If Not sh Is Nothing Then
v = Application.Match(.Cells(1, "B"), sh.Range("A5:A1504"), 0)
If Not IsError(v) Then
m = .Cells(1, "C")
Select Case .Cells(1, "D")
Case "一種"
sh.Cells(v + 4, IIf(m < 4, m + 15, m + 3)) = r
Case "二種"
sh.Cells(v + 5, IIf(m < 4, m + 15, m + 3)) = r
End Select
Else
MsgBox "対象番号 " & .Cells(1, "B") & " が有りません。" & vbLf & _
"番号を修正し、金額を再入力して下さい。"
End If
Else
MsgBox "対象シート " & .Cells(1, "E") & " が有りません。"
End If
On Error GoTo 0
Else
MsgBox "番号,月,種,費 の入力が不完全です。"
End If
End With
Next
End Sub
基本情報シートのシートモジュールに、
Private Sub Worksheet_Change(ByVal Target As Range)
Dim d As Object
Dim f As Boolean
Dim r As Range
Dim t As Range
Dim v As Variant
Dim sh As Worksheet
Set t = Intersect(Target, Range("B3:F752"))
If t Is Nothing Then Exit Sub
Set d = CreateObject("Scripting.Dictionary")
For Each r In t
f = True
For Each sh In Worksheets
If sh.Name Like "*費" Then
With sh
On Error Resume Next
v = Application.Match(r.EntireRow.Cells(1, "A"), .Range("A5:A1504"), 0)
If Not IsError(v) Then
.Cells(v + 4, r.Column) = r
.Cells(v + 5, r.Column) = r
Else
d.Item(CStr(r.EntireRow.Cells(1, "A"))) = _
CStr(r.EntireRow.Cells(1, "A"))
f = False
End If
On Error GoTo 0
End With
End If
Next
If f = False Then
MsgBox "対象番号 " & Join(d.Items, ",") & " が有りません。" & vbLf & _
"番号を修正し、情報を再入力して下さい。"
End If
Next
End Sub
を貼り付けて下さい。
基本情報シートの情報1～4 に入力すると各費目シートに反映されます。
Sheet1 に"番号", "月", "種", "費", "金額"の順に入力して、金額まで入れると対象費目シートの 対象月に金額が反映されます。
（ウッシ）
涙涙職場で歓声が湧き上がりました！ 問題はSheet1のA4からA20列目くらいまでに予め=B4&"-"&D4&"-"&"-"&C4&"-"&E4をオートフィル していたからでした！momoさんのやり方ならvlookupで参照しないのでもうA列はいらないのですね！ で一番ミスが起こらなそうな myMonth = Arrayを"4月"・・にして、Sheet1のC列を4月・・にして 文字列に指定しました。
あの・・で、データを更新(Sheet1の最終行に追加)してマクロを実行すると、 「シートの名前をほかのシート、VisualBasicで参照されるオブジェクトライブラリまたはワークシート と同じ名前に変更することはできません」と出て、作られたシートを全部削除してからまた実行すれば 大丈夫なのですが、毎回削除してから新しく作成することは出来ますでしょうか・・？
＞ウッシさん と書いている間に・・！ありがとうございます。ありがとうございます。 ちょちょちょっと、検証お待ちください。
(miffy)
動いてよかったです。 言い忘れてましたね。Sheet1のA列の情報は最初から使っていませんでした。
では、シート名が○○費となっているシートを事前に削除するコードと 一応、基本情報シートのB:E列が情報1～4だと仮定して情報も入力されるように 改変しましたので試してください。
Const MaxSyu As Long = 5 '種別数 Const MaxNin As Long = 150 '種別毎の人数
Sub test()
Dim i As Long, j As Long, k As Long, co As Long
Dim dat As Variant, tbl As Variant, buf As Variant, myMonth As Variant, myKey As Variant
Dim myR As Range, ws As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In Worksheets
If ws.Name Like "*費" Then
ws.Delete
End If
Next ws
Application.DisplayAlerts = True
With Worksheets("Sheet1")
With .Columns("A:F")
Set myR = .Find("*", .Cells(1), xlValues, xlPart, xlByRows, xlPrevious, False, False, False)
End With
tbl = .Range(.Range("A4"), myR.EntireRow.Columns("F")).Value
End With
myMonth = Array("4月", "5月", "6月", "7月", "8月", "9月", "10月", "11月", "12月", "1月", "2月", "3月")
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(tbl)
If Not .Exists(tbl(i, 5)) Then
Set .Item(tbl(i, 5)) = CreateObject("Scripting.Dictionary")
End If
With .Item(tbl(i, 5))
dat = .Item(tbl(i, 2) & vbTab & tbl(i, 4))
If IsArray(dat) = False Then ReDim dat(1 To 12)
dat(Application.WorksheetFunction.Match(tbl(i, 3), myMonth, 0)) = tbl(i, 6)
.Item(tbl(i, 2) & vbTab & tbl(i, 4)) = dat
End With
Next i
myKey = .Keys
ReDim DatBase(1 To MaxSyu * MaxNin * 2, 1 To 18)
co = 0
For i = 1 To MaxSyu
For j = 1 To MaxNin
For k = 1 To 2
DatBase(co + k, 1) = i * 1000 + j
DatBase(co + k, 2) = Application.Evaluate("=VLOOKUP(" & DatBase(co + k, 1) & ",基本情報!$A:$E,2,FALSE)")
DatBase(co + k, 3) = Application.Evaluate("=VLOOKUP(" & DatBase(co + k, 1) & ",基本情報!$A:$E,3,FALSE)")
DatBase(co + k, 4) = Application.Evaluate("=VLOOKUP(" & DatBase(co + k, 1) & ",基本情報!$A:$E,4,FALSE)")
DatBase(co + k, 5) = Application.Evaluate("=VLOOKUP(" & DatBase(co + k, 1) & ",基本情報!$A:$E,5,FALSE)")
DatBase(co + k, 6) = Choose(k, "一種", "二種")
Next k
co = co + 2
Next j
Next i
For i = 0 To UBound(myKey)
dat = DatBase
For j = 1 To UBound(dat)
buf = .Item(myKey(i)).Item(dat(j, 1) & vbTab & dat(j, 6))
If IsArray(buf) Then
For k = 1 To 12
dat(j, k + 6) = buf(k)
Next k
End If
Next j
With Worksheets.Add(After:=Worksheets(Worksheets.Count))
.Name = myKey(i)
.Range("A4:R4").Value = Array("番号", "情報1", "情報2", "情報3", "情報4", "種", _
"4月", "5月", "6月", "7月", "8月", "9月", "10月", "11月", "12月", "1月", "2月", "3月")
.Range("A5").Resize(UBound(dat), 18).Value = dat
End With
Next i
End With
Worksheets("Sheet1").Select
Application.ScreenUpdating = True
MsgBox "完了"
End Sub
（ｍｏｍｏ）
おまけです。
最後の方の
With Worksheets.Add(After:=Worksheets(Worksheets.Count))
.Name = myKey(i)
.Range("A4:R4").Value = Array("番号", "情報1", "情報2", "情報3", "情報4", "種", _
"4月", "5月", "6月", "7月", "8月", "9月", "10月", "11月", "12月", "1月", "2月", "3月")
.Range("A5").Resize(UBound(dat), 18).Value = dat
End With
のところを
With Worksheets.Add(After:=Worksheets(Worksheets.Count))
.Name = myKey(i)
.Range("A4:R4").Value = Array("番号", "情報1", "情報2", "情報3", "情報4", "種", _
"4月", "5月", "6月", "7月", "8月", "9月", "10月", "11月", "12月", "1月", "2月", "3月")
.Range("A5").Resize(UBound(dat), 18).Value = dat
.Range("A4").CurrentRegion.Borders.LineStyle = xlContinuous '罫線を引く
.Columns.AutoFit '幅をオートフィットする
End With
と２行追加すると、罫線を引いて幅をフィットします。 必要なければ削除で。 （ｍｏｍｏ）
罫線、ありがとうございます！実は出来るか聞いてみようかと思っていました。
・・やはり作られたシートがあると、「シートの名前をほかのシート、VisualBasicで参照される オブジェクトライブラリまたはワークシートと同じ名前に変更することはできません」と出て、 コードの下から13行目の .Name = mykey(i) が黄色くなります。 作られたシートを全部削除してからまた実行すれば大丈夫なのですが・・・
あとお時間があるときにで構わないのですが・・・ 基本情報シートで入力のないところがSheet2～(○○費)の情報1～4で#N/Aの表示が出るので 出ないようになると嬉しいです。 あとSheet2～(○○費)で一種と二種の間（なんというか同じ番号の行の間）の罫線をなくすか 点線のように出来ますでしょうか？見やすくなるだけなのですが・・・
(miffy)
Sheet1のE列に○○費と「費」が付いていない場合があるのでしょうね
これでどうでしょうか？ 前回までに出来た○○費シートは全部消してから実行してください。
Const MaxSyu As Long = 5 '種別数 Const MaxNin As Long = 150 '種別毎の人数
Sub test()
Dim i As Long, j As Long, k As Long, co As Long
Dim dat As Variant, tbl As Variant, buf As Variant, myMonth As Variant, myKey As Variant
Dim myR As Range, ws As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In Worksheets
If ws.Name Like "_*_" Then
ws.Delete
End If
Next ws
Application.DisplayAlerts = True
With Worksheets("Sheet1")
With .Columns("A:F")
Set myR = .Find("*", .Cells(1), xlValues, xlPart, xlByRows, xlPrevious, False, False, False)
End With
tbl = .Range(.Range("A4"), myR.EntireRow.Columns("F")).Value
End With
myMonth = Array("4月", "5月", "6月", "7月", "8月", "9月", "10月", "11月", "12月", "1月", "2月", "3月")
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(tbl)
If Not .Exists(tbl(i, 5)) Then
Set .Item(tbl(i, 5)) = CreateObject("Scripting.Dictionary")
End If
With .Item(tbl(i, 5))
dat = .Item(tbl(i, 2) & vbTab & tbl(i, 4))
If IsArray(dat) = False Then ReDim dat(1 To 12)
dat(Application.WorksheetFunction.Match(tbl(i, 3), myMonth, 0)) = tbl(i, 6)
.Item(tbl(i, 2) & vbTab & tbl(i, 4)) = dat
End With
Next i
myKey = .Keys
ReDim DatBase(1 To MaxSyu * MaxNin * 2, 1 To 18)
co = 0
For i = 1 To MaxSyu
For j = 1 To MaxNin
For k = 1 To 2
DatBase(co + k, 1) = i * 1000 + j
DatBase(co + k, 2) = Application.Evaluate("=VLOOKUP(" & DatBase(co + k, 1) & ",基本情報!$A:$E,2,FALSE)")
DatBase(co + k, 3) = Application.Evaluate("=VLOOKUP(" & DatBase(co + k, 1) & ",基本情報!$A:$E,3,FALSE)")
DatBase(co + k, 4) = Application.Evaluate("=VLOOKUP(" & DatBase(co + k, 1) & ",基本情報!$A:$E,4,FALSE)")
DatBase(co + k, 5) = Application.Evaluate("=VLOOKUP(" & DatBase(co + k, 1) & ",基本情報!$A:$E,5,FALSE)")
DatBase(co + k, 6) = Choose(k, "一種", "二種")
Next k
co = co + 2
Next j
Next i
For i = 0 To UBound(myKey)
dat = DatBase
For j = 1 To UBound(dat)
buf = .Item(myKey(i)).Item(dat(j, 1) & vbTab & dat(j, 6))
If IsArray(buf) Then
For k = 1 To 12
dat(j, k + 6) = buf(k)
Next k
End If
Next j
With Worksheets.Add(After:=Worksheets(Worksheets.Count))
.Name = "_" & myKey(i) & "_"
.Range("A4:R4").Value = Array("番号", "情報1", "情報2", "情報3", "情報4", "種", _
"4月", "5月", "6月", "7月", "8月", "9月", "10月", "11月", "12月", "1月", "2月", "3月")
With .Range("A5").Resize(UBound(dat), 18)
.Value = dat
.Replace What:="#N/A", Replacement:=""
.CurrentRegion.Borders.LineStyle = xlContinuous
Application.Intersect(.Columns("F").ColumnDifferences(.Range("F1")).EntireRow, Columns("A:R")).Borders(xlEdgeTop).Weight = xlHairline
End With
.Columns.AutoFit
End With
Next i
End With
Worksheets("Sheet1").Select
Application.ScreenUpdating = True
MsgBox "完了"
End Sub
（ｍｏｍｏ）
あぁ～感動です。 本当に感動です。
”費”、そうでした、○○費aとか○○費bとかありました。 こんなにわかりづらい説明で、こんなに長い時間、そして日中ずっと、本当にありがとうございました。 どのようにお礼を言ったら良いのかわからないですが、momoさん、そしてウッシさんや他の方の お陰で私だけではなく、少なくとも私と同じ管轄の担当約30人（それぞれ最大750人のデータを管理） が、感動することは間違いないです。 そして全国で見れば担当は数百人いると思われ、データは10万人以上になります。
そんな仕事を長年ほとんど手作業でやっているのですから、momoさん達からすると呆れた話なのでしょうけど・・
恐らく私の作るものが全国に採用されることはないでしょうが、これで救われる人の数は 計り知れません。
まだマクロの初級の本を二冊読みかけているだけですが、いつかmomoさん達のように誰かの役に 立てたら良いと思います。
(miffy)
出来たようですね。よかったです。 本を読まれているようですが、時間のあるときに色々な人のコードを見て それをヘルプで調べるだけでかなりの事が出来るようになると思います。
ヒントを出す回答者と、私のようにコードを書いてしまう回答者と居ますが どちらも有用だと思います。 私は後者です。私自身が色々な方のコードを見ることで覚えてきたので。
私もネットとヘルプくらいしか知りません（本は見たことありません） なので私のコードは、熟練の方からすると個性的なのだと思います。
我流も続けると定番になっていったり、色々面白い事がありますね。 違ったアプローチでイベントプロシージャで処理されているウッシさんのコードも 突き詰めると面白いと思います。
１つの事を実現するのに色々な方法があるので楽しいです。（なので趣味です） 今回は実現するためのサンプルを書かせてもらいましたが 理想とする動作とコードの順序や組み立て方などを見て頂ければと思います。
頑張ってください｡ （ｍｏｍｏ）
あの・・・お時間のあるときで・・・ 7月と8月の間（K列)に4～7月小計を、12月と1月の間(Q列)に8月～12月小計を、3月の後(U列)に 1～3月小計を、最終列(V列)に合計を・・・というのと、 1000番台・2000番台・3000番台・4000番台・5000番台のそれぞれ最後の行の下に小計（一種二種と2段分）を、 最終行に合計（一種二種と2段分）を・・・ 各小計から別の集計の表を作らなければならないので、できますでしょうか・・・ (miffy)
一応修正しておきました。
新規ブックで、
Sub jyunbi_Sheet1()
With Worksheets("Sheet1")
.Range("B3:F3").Value = Array("番号", "月", "種", "費", "金額")
End With
End Sub
Sub jyunbi_費目シート雛形Sheet2()
Dim h As Long
Dim i As Long
Dim j As Long
Dim k As Long
With Worksheets("Sheet2")
.UsedRange.Clear 'Contents
For k = 0 To 4
h = k * 302 + 5
i = k * 1000 + 1000
For j = 0 To 149
.Cells(h + j, 1) = i + j + 1
.Cells(h + j + 1, 1) = i + j + 1
.Cells(h + j, "F") = "一種"
.Cells(h + j + 1, "F") = "二種"
h = h + 1
Next
.Cells(h + 150, "E") = i & "一種小計"
.Cells(h + 150 + 1, "E") = i & "二種小計"
.Cells(h + 150, "F") = "一種"
.Cells(h + 150 + 1, "F") = "二種"
.Cells(h + 150, "G").Resize(, 16).FormulaR1C1 = _
"=SUMIF(R[-300]C6:R[-1]C6,RC6,R[-300]C:R[-1]C)"
.Cells(h + 150 + 1, "G").Resize(, 16).FormulaR1C1 = _
"=SUMIF(R[-301]C6:R[-2]C6,RC6,R[-301]C:R[-2]C)"
h = h + 1
Next
h = h + 151
.Cells(h, "E") = "合計"
.Cells(h + 1, "E") = "合計"
.Cells(h, "F") = "一種"
.Cells(h + 1, "F") = "二種"
.Cells(h, "G").Resize(, 16).FormulaR1C1 = _
"=SUMIF(R5C5:R[-1]C5,""*一種小計"",R5C:R[-1]C)"
.Cells(h + 1, "G").Resize(, 16).FormulaR1C1 = _
"=SUMIF(R5C5:R[-2]C5,""*二種小計"",R5C:R[-2]C)"
.Range("A4:V4").Value = Array("番号", "情報1", "情報2", "情報3", "情報4", "種", _
"4", "5", "6", "7", "4～7月計", "8", "9", "10", "11", "12", "8～12月計", "1", "2", "3", "1～3月計", "合計")
.Range("G4:V4").NumberFormatLocal = "#""月"""
With .Range("A4").CurrentRegion
.Borders.LineStyle = xlContinuous
Intersect(.Columns("F").ColumnDifferences(.Range("F2")).EntireRow, .Columns("A:V")).Borders(xlEdgeTop).Weight = xlHairline
.Range("A1:V1").Borders(xlEdgeTop).Weight = xlThin
End With
.Columns.AutoFit
End With
End Sub
Sub jyunbi_基本()
Dim h As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim s As Worksheet
On Error Resume Next
Set s = Worksheets("基本情報")
If s Is Nothing Then
Set s = Worksheets.Add(Worksheets("Sheet1"))
s.Name = "基本情報"
End If
On Error GoTo 0
With s
.Range("A2").Value = "番号"
.Range("B2").Value = "情報1"
.Range("B2").AutoFill Destination:=.Range("B2:S2"), Type:=xlFillDefault
For k = 0 To 4
h = k * 150 + 3
i = k * 1000 + 1000
For j = 0 To 149
.Cells(h + j, 1) = i + j + 1
Next
Next
End With
End Sub
ここまでを順番に実行して下さい。
この下の２本のコードはデータからのリカバリ時に実行するものです。
'基本情報シート、Sheet2 が作成された状態でSheet1 のデータから費目シートを作成する際に実行する。
Sub Sheet1データから全費目シート再作成()
Dim sh As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sh In Worksheets
If InStr(1, sh.Name, "費") > 0 Then
sh.Delete
End If
Next
With Worksheets("Sheet1")
.Activate
.Range("F4", .Range("F" & .Rows.Count).End(xlUp)).Cut
.Range("F4").Select
.Paste
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
'基本情報シートのデータからSheet2、費目シートの情報1～4を更新する際に実行する。
Sub 基本情報データから情報を更新()
Dim r As Range
Dim s As Range
Dim sh As Worksheet
Dim h As Long
Dim k As Long
Application.ScreenUpdating = False
With Worksheets("基本情報")
.Activate
On Error Resume Next
With .Range("A3", .Range("A" & .Rows.Count).End(xlUp)).Offset(, 1).Resize(, 4)
Set s = .SpecialCells(xlCellTypeConstants)
If Not s Is Nothing Then
For Each r In s.Areas
r.Cut
r.Select
Worksheets("基本情報").Paste
Next
Else
For Each sh In Worksheets
If InStr(1, sh.Name, "費") > 0 Or sh.Name = "Sheet2" Then
For k = 0 To 4
h = k * 302 + 5
sh.Cells(h, 2).Resize(300, 4).ClearContents
Next
End If
Next
End If
End With
On Error GoTo 0
End With
Application.ScreenUpdating = True
End Sub
シートモジュールのイベントマクロも差し替えて下さい。、
Sheet1のシートモジュールに、
Private Sub Worksheet_Change(ByVal Target As Range)
Dim e As Long
Dim m As Long
Dim r As Range
Dim t As Range
Dim v As Variant
Dim sh As Worksheet
Dim a As Variant
Dim i As Long
e = Range("F" & Rows.Count).End(xlUp).Row
If e <= 3 Then Exit Sub
Set t = Intersect(Target, Range("F4:F" & e))
If t Is Nothing Then Exit Sub
' 1 2 3 4 5 6 7 8 9 10 11 12 月対応列
a = Array(0, 18, 19, 20, 7, 8, 9, 10, 12, 13, 14, 15, 16)
Application.ScreenUpdating = False
For Each r In t
With r.EntireRow
If WorksheetFunction.CountA(.Cells(1, "B").Resize(, 4)) = 4 Then
On Error Resume Next
Set sh = Nothing
Set sh = Worksheets(CStr(.Cells(1, "E")))
If sh Is Nothing Then
Worksheets("Sheet2").Copy after:=Worksheets(Worksheets.Count)
Set sh = Worksheets(Worksheets.Count)
sh.Name = CStr(.Cells(1, "E"))
End If
v = Application.Match(.Cells(1, "B"), sh.Range("A5:A1512"), 0)
If Not IsError(v) Then
m = .Cells(1, "C")
Select Case .Cells(1, "D")
Case "一種": i = 4
Case "二種": i = 5
Case Else: i = 0
End Select
If i > 0 Then
sh.Cells(v + i, a(m)) = r
sh.Cells(v + i, "K") = 0
sh.Cells(v + i, "Q") = 0
sh.Cells(v + i, "U") = 0
sh.Cells(v + i, "V") = 0
sh.Cells(v + i, "K") = WorksheetFunction.Sum(sh.Cells(v + i, a(4)).Resize(, 4))
sh.Cells(v + i, "Q") = WorksheetFunction.Sum(sh.Cells(v + i, a(8)).Resize(, 5))
sh.Cells(v + i, "U") = WorksheetFunction.Sum(sh.Cells(v + i, a(1)).Resize(, 3))
sh.Cells(v + i, "V") = WorksheetFunction.Sum( _
sh.Cells(v + i, "K"), sh.Cells(v + i, "Q"), sh.Cells(v + i, "V"))
End If
Else
MsgBox "対象番号 " & .Cells(1, "B") & " が有りません。" & vbLf & _
"番号を修正し、金額を再入力して下さい。"
End If
On Error GoTo 0
Else
MsgBox "番号,月,種,費 の入力が不完全です。"
End If
End With
Next
Application.ScreenUpdating = True
End Sub
基本情報シートのシートモジュールに、
Private Sub Worksheet_Change(ByVal Target As Range)
Dim d As Object
Dim f As Boolean
Dim r As Range
Dim t As Range
Dim v As Variant
Dim sh As Worksheet
Set t = Intersect(Target, Range("B3:F752"))
If t Is Nothing Then Exit Sub
Set d = CreateObject("Scripting.Dictionary")
For Each r In t
f = True
For Each sh In Worksheets
If InStr(1, sh.Name, "費") > 0 Or sh.Name = "Sheet2" Then
With sh
On Error Resume Next
v = Application.Match(r.EntireRow.Cells(1, "A"), .Range("A5:A1512"), 0)
If Not IsError(v) Then
.Cells(v + 4, r.Column) = r
.Cells(v + 5, r.Column) = r
Else
d.Item(CStr(r.EntireRow.Cells(1, "A"))) = _
CStr(r.EntireRow.Cells(1, "A"))
f = False
End If
On Error GoTo 0
End With
End If
Next
Next
If f = False Then
MsgBox "対象番号 " & Join(d.Items, ",") & " が有りません。" & vbLf & _
"番号を修正し、情報を再入力して下さい。"
End If
End Sub
を貼り付けて下さい。
基本情報シートの情報1～4 に入力すると各費目シートに反映されます。
Sheet1 に"番号", "月", "種", "費", "金額"の順に入力して、金額まで入れると対象費目シートの 対象月に金額が反映されます。
基本情報シート、 Sheet1 のデータは他のブックからの複数セルのコピペでもＯＫです。
罫線のコードは ｍｏｍｏさんのコードお借りしました。m(__)m
（ウッシ）
夜中に・・・どうもありがとうございます！ あの、実は、昨日も、勉強不足でどう操作したらよいのかわからずうまく動かせなかったのです。 一番最初の”Sub jyunbi_Sheet1()”～”ここまでを順番に実行して下さい。”の上までは 挿入→標準モジュール（Module1が作成される）でコードをコピーしてマクロ実行で「基本情報」シートが追加されました。 そのあと”この下の２本のコードはデータからのリカバリ時に実行するものです。”の下から ”シートモジュールのイベントマクロも差し替えて下さい”の上までを挿入→標準モジュール （Module2が作成される）でコードをコピーして、とりあえず実行しない、で良いでしょうか。 そのあと”Sheet1のシートモジュールに、”の下から”基本情報シートのシートモジュールに、” の上までをMicrosoft Excel Objectの下のSheet1(Sheet1)をダブルクリックして右の枠内にコードをコピー、 ”基本情報シートのシートモジュールに、”の下からEnd Subまでを同じくSheet4（基本情報）を ダブルクリックして右の枠内にコピーをして・・・そのあとどうしたら良いのかわかりません・・ VBEを開いた状態でSheet1(Sheet1)をダブルクリックしてマクロ実行ボタンを押すとマクロを選ぶように ボックスが出て、（jyunbi_Sheet1、jyunbi_基本、jyunbi_費目シート雛形Sheet2、基本情報データから情報を更新の4つ） どれでも一つ選択して実行をクリックすると ”コンパイルエラー：プロシージャの外では無効です”と出ます。
すみません・・・ 確認ですが、新規ブックを開いた時にSheet1～Sheet3まで最初からありますが、削除しなくて良いでしょうか。
Sheet1 の B3～F3 に項目名セット。 Sheet2 は、費目シートのひな型として項目名と番号1001～5150、罫線、小計合計の式をセット。 基本情報シート の A2～S2 まで項目名、A3以下に番号をセット。
までが「jyunbi～」で出来てますか？
その後、基本情報シート と Sheet1 のシートモジュールに各イベントマクロを貼り付けまで終わっているのですよね？
でしたら、
基本情報シート にセットするデータが他のブックに既に有るのでしたら、そのデータをコピーしてセル B3 以下に貼り付けて下さい。 情報1、情報2、情報3、情報4のデータが 基本情報シートのイベントマクロによって、 Sheet2 の対応する番号の情報エリアに転記されます。
次に、Sheet1 にセットするデータが他のブックに既に有るのでしたら、そのデータをコピーしてセル B4 以下に貼り付けて下さい。 番号、月、種、費、金額 まとめてコピペすれば Sheet1 のイベントマクロによって、 「費」の行に有るデータで費目シートが自動で作成され、金額が転記されます。 これは貼り付けたデータが多いと少し時間が掛りますけど、一度きりの作業なので待って下さい。
それ以降は、 Sheet1 にデータを追加するごとに 対応する費目シートの番号、種、月の部分に金額が転記されます。
Sub Sheet1データから全費目シート再作成 と Sub 基本情報データから情報を更新() は、それぞれのシートのデータから費目シート、情報のセットをやり直す時に実行しますので、今は実行する必要はないです。
Sheet1 の 番号、月、種、費 には重複が無いという前提になってます。 ユーザーフォーム等で入力する際に重複チェックを入れて下さい。
（ウッシ）
わかりましたぁーーー＞＜ 基本的な「順番に実行する」の意味がわかっていませんでした＞＜ junbiで各プロシージャを上からカーソルを持って行って一つづつ実行するんですね、 コードをコピーしたらそのまま一回だけ実行して終わってしまっていました；；
すごいですーーーー！ momoさんのともまた違って、入力するとマクロ実行しなくてもどんどん更新されていくんですね！ シートモジュールにイベントマクロ・・・まだまだ勉強不足ですが・・すごいですね！！ 都度実行しないから時間もそんなにかからない感じなのですね・・・ ちなみになのですが、もし150人づつ5種類ではなく50人づつとか200人づつに変更したいときは 標準モジュール内のjunbi_費目シートと基本の中の”150”や”151”となっているところなどを 変更すると出来るのでしょうか・・？
momoさんのおっしゃるとおり全然違うアプローチで同じような求めるものができるものなんですねー・・
・・・ウッシさん・・いつ寝られてるんでしょう・・・
(miffy)
'モジュールの先頭に追加・・・ｍｏｍｏさんのお借りしました。 Const MaxSyu As Long = 2 '種別数 Const MaxNin As Long = 20 '種別毎の人数
'差し替え
Sub jyunbi_費目シート雛形Sheet2()
Dim h As Long
Dim i As Long
Dim j As Long
Dim k As Long
With Worksheets("Sheet2")
.UsedRange.Clear 'Contents
For k = 0 To MaxSyu - 1
h = k * (MaxNin * 2 + 2) + 5
i = k * 1000 + 1000
For j = 0 To MaxNin - 1
.Cells(h + j, 1) = i + j + 1
.Cells(h + j + 1, 1) = i + j + 1
.Cells(h + j, "F") = "一種"
.Cells(h + j + 1, "F") = "二種"
h = h + 1
Next
.Cells(h + MaxNin, "E") = i & "一種小計"
.Cells(h + MaxNin + 1, "E") = i & "二種小計"
.Cells(h + MaxNin, "F") = "一種"
.Cells(h + MaxNin + 1, "F") = "二種"
.Cells(h + MaxNin, "G").Resize(, 16).FormulaR1C1 = _
"=SUMIF(R[-" & MaxNin * 2 & "]C6:R[-1]C6,RC6,R[-" & MaxNin * 2 & "]C:R[-1]C)"
.Cells(h + MaxNin + 1, "G").Resize(, 16).FormulaR1C1 = _
"=SUMIF(R[-" & MaxNin * 2 + 1 & "]C6:R[-2]C6,RC6,R[-" & MaxNin * 2 + 1 & "]C:R[-2]C)"
h = h + 1
Next
h = h + MaxNin + 1
.Cells(h, "E") = "合計"
.Cells(h + 1, "E") = "合計"
.Cells(h, "F") = "一種"
.Cells(h + 1, "F") = "二種"
.Cells(h, "G").Resize(, 16).FormulaR1C1 = _
"=SUMIF(R5C5:R[-1]C5,""*一種小計"",R5C:R[-1]C)"
.Cells(h + 1, "G").Resize(, 16).FormulaR1C1 = _
"=SUMIF(R5C5:R[-2]C5,""*二種小計"",R5C:R[-2]C)"
.Range("A4:V4").Value = Array("番号", "情報1", "情報2", "情報3", "情報4", "種", _
"4", "5", "6", "7", "4～7月計", "8", "9", "10", "11", "12", "8～12月計", "1", "2", "3", "1～3月計", "合計")
.Range("G4:V4").NumberFormatLocal = "#""月"""
With .Range("A4").CurrentRegion
.Borders.LineStyle = xlContinuous
Intersect(.Columns("F").ColumnDifferences(.Range("F2")).EntireRow, .Columns("A:V")).Borders(xlEdgeTop).Weight = xlHairline
.Range("A1:V1").Borders(xlEdgeTop).Weight = xlThin
End With
.Columns.AutoFit
End With
End Sub
Sub jyunbi_基本()
Dim h As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim s As Worksheet
On Error Resume Next
Set s = Worksheets("基本情報")
If s Is Nothing Then
Set s = Worksheets.Add(Worksheets("Sheet1"))
s.Name = "基本情報"
Else
Application.EnableEvents = False
End If
On Error GoTo 0
With s
.UsedRange.ClearContents
.Range("A2").Value = "番号"
.Range("B2").Value = "情報1"
.Range("B2").AutoFill Destination:=.Range("B2:S2"), Type:=xlFillDefault
For k = 0 To MaxSyu - 1
h = k * MaxNin + 3
i = k * 1000 + 1000
For j = 0 To MaxNin - 1
.Cells(h + j, 1) = i + j + 1
Next
Next
End With
Application.EnableEvents = True
End Sub
'基本情報シートのデータからSheet2、費目シートの情報1～4を更新する際に実行する。
Sub 基本情報データから情報を更新()
Dim r As Range
Dim s As Range
Dim sh As Worksheet
Dim h As Long
Dim k As Long
Application.ScreenUpdating = False
With Worksheets("基本情報")
.Activate
On Error Resume Next
With .Range("A3", .Range("A" & .Rows.Count).End(xlUp)).Offset(, 1).Resize(, 4)
Set s = .SpecialCells(xlCellTypeConstants)
If Not s Is Nothing Then
For Each r In s.Areas
r.Cut
r.Select
Worksheets("基本情報").Paste
Next
Else
For Each sh In Worksheets
If InStr(1, sh.Name, "費") > 0 Or sh.Name = "Sheet2" Then
For k = 0 To 4
h = k * (MaxNin * 2 + 2) + 5
sh.Cells(h, 2).Resize(MaxNin * 2, 4).ClearContents
Next
End If
Next
End If
End With
On Error GoTo 0
End With
Application.ScreenUpdating = True
End Sub
シートモジュールのイベントマクロも差し替えて下さい。、
Sheet1のシートモジュール、
Private Sub Worksheet_Change(ByVal Target As Range)
Dim e As Long
Dim m As Long
Dim r As Range
Dim t As Range
Dim v As Variant
Dim sh As Worksheet
Dim a As Variant
Dim i As Long
e = Range("F" & Rows.Count).End(xlUp).Row
If e <= 3 Then Exit Sub
Set t = Intersect(Target, Range("F4:F" & e))
If t Is Nothing Then Exit Sub
' 1 2 3 4 5 6 7 8 9 10 11 12 月対応列
a = Array(0, 18, 19, 20, 7, 8, 9, 10, 12, 13, 14, 15, 16)
Application.ScreenUpdating = False
For Each r In t
With r.EntireRow
If WorksheetFunction.CountA(.Cells(1, "B").Resize(, 4)) = 4 Then
On Error Resume Next
Set sh = Nothing
Set sh = Worksheets(CStr(.Cells(1, "E")))
If sh Is Nothing Then
Worksheets("Sheet2").Copy after:=Worksheets(Worksheets.Count)
Set sh = Worksheets(Worksheets.Count)
sh.Name = CStr(.Cells(1, "E"))
End If
v = Application.Match(.Cells(1, "B"), sh.Range("A5", sh.Range("A" & Rows.Count).End(xlUp)), 0)
If Not IsError(v) Then
m = .Cells(1, "C")
Select Case .Cells(1, "D")
Case "一種": i = 4
Case "二種": i = 5
Case Else: i = 0
End Select
If i > 0 Then
sh.Cells(v + i, a(m)) = r
sh.Cells(v + i, "K") = 0
sh.Cells(v + i, "Q") = 0
sh.Cells(v + i, "U") = 0
sh.Cells(v + i, "V") = 0
sh.Cells(v + i, "K") = WorksheetFunction.Sum(sh.Cells(v + i, a(4)).Resize(, 4))
sh.Cells(v + i, "Q") = WorksheetFunction.Sum(sh.Cells(v + i, a(8)).Resize(, 5))
sh.Cells(v + i, "U") = WorksheetFunction.Sum(sh.Cells(v + i, a(1)).Resize(, 3))
sh.Cells(v + i, "V") = WorksheetFunction.Sum( _
sh.Cells(v + i, "K"), sh.Cells(v + i, "Q"), sh.Cells(v + i, "V"))
End If
Else
MsgBox "対象番号 " & .Cells(1, "B") & " が有りません。" & vbLf & _
"番号を修正し、金額を再入力して下さい。"
End If
On Error GoTo 0
Else
MsgBox "番号,月,種,費 の入力が不完全です。"
End If
End With
Next
Application.ScreenUpdating = True
End Sub
基本情報シートのシートモジュール、
Private Sub Worksheet_Change(ByVal Target As Range)
Dim d As Object
Dim f As Boolean
Dim r As Range
Dim t As Range
Dim v As Variant
Dim sh As Worksheet
Set t = Intersect(Target, Range("B3:F752"))
If t Is Nothing Then Exit Sub
Set d = CreateObject("Scripting.Dictionary")
For Each r In t
f = True
For Each sh In Worksheets
If InStr(1, sh.Name, "費") > 0 Or sh.Name = "Sheet2" Then
With sh
On Error Resume Next
v = Application.Match(r.EntireRow.Cells(1, "A"), .Range("A5", .Range("A" & Rows.Count).End(xlUp)), 0)
If Not IsError(v) Then
.Cells(v + 4, r.Column) = r
.Cells(v + 5, r.Column) = r
Else
d.Item(CStr(r.EntireRow.Cells(1, "A"))) = _
CStr(r.EntireRow.Cells(1, "A"))
f = False
End If
On Error GoTo 0
End With
End If
Next
Next
If f = False Then
MsgBox "対象番号 " & Join(d.Items, ",") & " が有りません。" & vbLf & _
"番号を修正し、情報を再入力して下さい。"
End If
End Sub
今朝は猫に起こされました。
（ウッシ）
できましたぁ～～～～～～ うわぁ～～～ほんとにこんなに長いコードを作っていただいて・・・（この掲示板でもなかなかないのでは） momoさんもですが、外注したらかなり費用かかりますよね・・・ というかこれで生業にしていないとしたらもったいないにもほどがあるような・・・ （余計なお世話でスミマセン） なんか、基本情報シートも雛形が自動で作られるところがすごいですね！（いや、他もすごいところは 数え切れませんが･･･） う～～んスバラシイ・・・
私は今朝パソコンパソコンと起き上がった瞬間メガネを踏んで金具がボキっと折れて分離して、今片耳 と鼻で支えてます。・・・ファイル作りが気になって買いに行けませんわー。（会社はコンタクト）
表の書式とかを整えて（それは昨晩なんとか出来そうでした）、あとは来週上司に一人コンペって感じ ですかねー･･･ どちらもスバラシイので私の説明がうまくいくかですが･･･
最初はvlookupで全部作ろうとしていたので、費目ごとの表が出来るまでに1週間以上かかってかつ 処理速度もかなり遅いだろうと思っていたので、こんなに違う方法で一瞬にどんどん出来上がっていく なんて夢のようです。
何度もありがとうございました。 それぞれ集計表が別途必要なので、がんばって作ります！
(miffy)
すみません、どうしてもわからないことがあります。
作成される費目シートの列幅が自動調整されず、金額が###となってしまいます。
なにもかもおんぶにだっこで本当に申し訳ありません。
ここかなと思ったところをずっと見てはいるのですがいじっても直りません・・・
Sub jyunbi_費目シート雛形Sheet2()の最後に.Columns.AutoFitとあるのが前にmomoさんが
'自動調整 とメモをつけてくれていたコードだったので、もしかしてSheet1のシートモジュールで
Worksheets("Sheet2").Copy after:=Worksheets(Worksheets.Count) とされた後に
また調整しなければならないのかなと思いその下の方にいれてみたりしたのですがうまくいきません。
これで最後のつもりです、ほんとにすみません。 (miffy)
Sheet1のシートモジュールで、
Private Sub Worksheet_Change(ByVal Target As Range)
Dim e As Long
Dim m As Long
Dim r As Range
Dim t As Range
Dim v As Variant
Dim sh As Worksheet
Dim a As Variant
Dim i As Long
e = Range("F" & Rows.Count).End(xlUp).Row
If e <= 3 Then Exit Sub
Set t = Intersect(Target, Range("F4:F" & e))
If t Is Nothing Then Exit Sub
' 1 2 3 4 5 6 7 8 9 10 11 12 月対応列
a = Array(0, 18, 19, 20, 7, 8, 9, 10, 12, 13, 14, 15, 16)
Application.ScreenUpdating = False
For Each r In t
With r.EntireRow
If WorksheetFunction.CountA(.Cells(1, "B").Resize(, 4)) = 4 Then
On Error Resume Next
Set sh = Nothing
Set sh = Worksheets(CStr(.Cells(1, "E")))
If sh Is Nothing Then
Worksheets("Sheet2").Copy after:=Worksheets(Worksheets.Count)
Set sh = Worksheets(Worksheets.Count)
sh.Name = CStr(.Cells(1, "E"))
End If
v = Application.Match(.Cells(1, "B"), sh.Range("A5", sh.Range("A" & Rows.Count).End(xlUp)), 0)
If Not IsError(v) Then
m = .Cells(1, "C")
Select Case .Cells(1, "D")
Case "一種": i = 4
Case "二種": i = 5
Case Else: i = 0
End Select
If i > 0 Then
sh.Cells(v + i, a(m)) = r
sh.Cells(v + i, "K") = 0
sh.Cells(v + i, "Q") = 0
sh.Cells(v + i, "U") = 0
sh.Cells(v + i, "V") = 0
sh.Cells(v + i, "K") = WorksheetFunction.Sum(sh.Cells(v + i, a(4)).Resize(, 4))
sh.Cells(v + i, "Q") = WorksheetFunction.Sum(sh.Cells(v + i, a(8)).Resize(, 5))
sh.Cells(v + i, "U") = WorksheetFunction.Sum(sh.Cells(v + i, a(1)).Resize(, 3))
sh.Cells(v + i, "V") = WorksheetFunction.Sum( _
sh.Cells(v + i, "K"), sh.Cells(v + i, "Q"), sh.Cells(v + i, "V"))
End If
sh.Range("G:V").Columns.AutoFit 'ここに追加
Else
MsgBox "対象番号 " & .Cells(1, "B") & " が有りません。" & vbLf & _
"番号を修正し、金額を再入力して下さい。"
End If
On Error GoTo 0
Else
MsgBox "番号,月,種,費 の入力が不完全です。"
End If
End With
Next
Application.ScreenUpdating = True
End Sub
（ウッシ）
またすごい時間に・・・・・・＞＜ ありがとうございますありがとうございますありがとうございます！！！
あら、土日外出してたので見られませんでした。 すみません。
小計を入れるとなると～ 私のは小計用のプロシージャを組み込むか 少し処理を追加しないといけませんね。
もし、ご希望があれば見直してみますがレス内容を拝見していると イベント制御も良さそうな感じですのでとりあえず静観させて頂きます。
ウッシさんフォロー＆別案ありがとうです。 （ｍｏｍｏ）
わざわざ書き込みありがとうございます。 ・・・実は・・・ 土日も今日もほとんどファイル作りをしていたのですが・・・ 集計表を何パターンか作らなければならず（何というかデータそのものは変わらないのですが 「費目ごとシート」の他に「個人ごとシート」や「4～7月ごとシート」や・・）、その集計表を ウッシさんやmomoさんのを参考にマクロで作ろうとして挫折して、vlookupで作ろうとして挫折して （初めから費目シートがないと#REF!となってしまってそのあとシートが作られても式が無効に なってしまっている。） なんだか勉強不足なのにやろうとしてしまった自分のすべてが間違っていたのではないかと自己嫌悪の状況です。 ・・・日中つきっきりで書き込みしてくださったmomoさんや夜中の3時4時にも修正してくださった ウッシさんのお力は絶対に無駄にはしませんので、今年度はちょっと間に合わないかもしれませんが ・・・一旦頭を冷やして、作っていただいたコードを読み解いて、一日でも早く実務に活かしたいと思います。 歯切れの悪い書き込みですみません・・ (miffy)
「個人ごとシート」って・・・750シート作るつもりですか？ ちょっと考え直した方がいいのでは？
個人番号を指定してその都度集計して表示する位でいいんじゃないですか？ 個人毎に配布したければ個人別に別ブックで保存することも出来ますけど、1ブックで750シートとかは・・・
（ウッシ）
書き込みありがとうございます。帰宅しながらどうやって乗り切ろうかと考えてました。 「個人ごとシート」は、従来は、1000番台、2000番台・・・ごとにシートになっていて、横軸が費目、 縦軸が月なので、実際年度末にしか一括印刷しないものです。 私は今回シートが多数になるのを避けたかったので一つのシートにできるだけ表示してしまおうかと思ったのですが・・・ ウッシさんの言葉をヒントに、差し込み印刷のマクロをイメージして次、次とボタンで表示できれば 良さそうですね・・・ 個人ごとシートは、入力シート(Sheet1)と基本情報シートの内容から作れるので、時間があれば何とか 力ずくでもvlookupで作れるかなと思っていたのですが･･･（1000番台ごとシートかなぁと思っていました）。 「4～7月ごとシート」は、比較的急いで作りたいもので（9月末までに今年度の7月までの集計が必要のため）、 横軸が費目、縦軸が人になっています。従来は一種、二種ごとに別シート、かつ1000番台ごとに別シート になっていたので、Sheet2のように種が上下＋一気に最後の人までで表示できればシートが一つで済むと 思い、これを今日一日チャレンジしたのですが、マクロで出来上がった費目シートからデータが引っ張れず、 入力シート(Sheet1)の情報からでは作れず、今考えうる出来そうな事といえば出来上がった費目シート の4月～7月計を上からコピーして貼り付け・・を全費目・・・ 一昨日の眼鏡のように情けない状態です･･･ (miffy)
Sheet1 の G列、H列 を作業列として使用します。
Sub 期間分け()
Dim Sh As Worksheet
Dim Ptbl As PivotTable
On Error Resume Next
Set Sh = Worksheets("期間分け")
If Sh Is Nothing Then
Set Sh = Worksheets.Add
Sh.Name = "期間分け"
End If
On Error GoTo 0
Sh.UsedRange.Delete
With Worksheets("Sheet1")
.Activate
Application.EnableEvents = False
.Range("G3").Value = "期間分け"
With .Range("B3", .Range("B" & .Rows.Count).End(xlUp))
With .Offset(1, 5).Resize(.Count - 1)
.Formula = _
"=IF(C4<4,""1～3月"",IF(C4>7,""8～12月"",""4～7月""))"
.Value = .Value
End With
Application.EnableEvents = True
ThisWorkbook.Names.Add Name:="Database", RefersToR1C1:="=" & .Resize(, 6).Address(1, 1, xlR1C1, True)
Set Ptbl = ThisWorkbook.PivotCaches.Add( _
SourceType:=xlDatabase, _
SourceData:="Database") _
.CreatePivotTable( _
TableDestination:=Sh.Name & "!" & Sh.Range("A1").Address(1, 1, xlR1C1), _
TableName:="Tbl", DefaultVersion:=xlPivotTableVersion10)
End With
With Ptbl
With .PivotFields("番号")
.Orientation = xlRowField
.Position = 1
.Subtotals = Array( _
False, False, False, False, False, False, False, False, False, False, False, False)
End With
With .PivotFields("種")
.Orientation = xlRowField
.Position = 2
End With
.AddDataField .PivotFields("金額"), "合計 / 金額", xlSum
With .PivotFields("期間分け")
.Orientation = xlPageField
.Position = 1
End With
With .PivotFields("費")
.Orientation = xlColumnField
.Position = 1
End With
.PivotFields("期間分け").CurrentPage = "4～7月"
End With
Sh.UsedRange.Columns.AutoFit
.Parent.ShowPivotTableFieldList = False
End With
End Sub
Sub 個人分け()
Dim Sh As Worksheet
Dim Ptbl As PivotTable
On Error Resume Next
Set Sh = Worksheets("個人分け")
If Sh Is Nothing Then
Set Sh = Worksheets.Add
Sh.Name = "個人分け"
End If
On Error GoTo 0
Sh.UsedRange.Delete
With Worksheets("Sheet1")
.Activate
Application.EnableEvents = False
.Range("H3").Value = "個人分け"
With .Range("B3", .Range("B" & .Rows.Count).End(xlUp))
With .Offset(1, 6).Resize(.Count - 1)
.Formula = "=FLOOR(B4,1000)"
.Value = .Value
End With
Application.EnableEvents = True
ThisWorkbook.Names.Add Name:="Database1", RefersToR1C1:="=" & .Resize(, 7).Address(1, 1, xlR1C1, True)
Set Ptbl = ThisWorkbook.PivotCaches.Add( _
SourceType:=xlDatabase, _
SourceData:="Database1") _
.CreatePivotTable( _
TableDestination:=Sh.Name & "!" & Sh.Range("A1").Address(1, 1, xlR1C1), _
TableName:="Tbl", DefaultVersion:=xlPivotTableVersion10)
End With
With Ptbl
With .PivotFields("月")
.Orientation = xlRowField
.Position = 1
.Subtotals = Array( _
False, False, False, False, False, False, False, False, False, False, False, False)
End With
.AddDataField .PivotFields("金額"), "合計 / 金額", xlSum
With .PivotFields("個人分け")
.Orientation = xlPageField
.Position = 1
End With
With .PivotFields("費")
.Orientation = xlColumnField
.Position = 1
End With
.PivotFields("個人分け").CurrentPage = "1000"
End With
Sh.UsedRange.Columns.AutoFit
.Parent.ShowPivotTableFieldList = False
End With
End Sub
どちらもピボットテーブルのページフィールドで期間「4～7月」「8～12月」「1～3月」
と個人番号「1000」「2000」「3000」～が選択出来ます。
（ウッシ）
う～～～T_T) 本当にすみません ありがとうございます 泣きついてばかりで情けないし申し訳ないです。 今データがないので会社ですぐにやってみます。 (miffy)
ありがとうございました、無事にピボットテーブルで作成できました！
私の書き方が悪くて、個人ごとの1000番台というのは、1001～1150番目の人まで一人づつ1シート、 2001～2150までで1シート・・・という意味だったのですが、下から6行目の.CurrentPage = "1000" のところをなくしたら個人ごとに表示できました！ 申し訳ないのが色々すぎてもう言葉がありません・・・ 本当にありがとうございました。 (miffy)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.