[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『シートのマッチング』（hikomitsu）
シートを組と番号でマッチングし、マッチしたら金額をセットする処理は どのようにすればいいか、教えていただけないでしょうか？ (Excel2007) ブック内にシートA,B,C,D,E,F,G,H,I,J と金額のシートがあり、 Aシートは 組 番・・・・・金額 A 1 A 2 A 3 A 4 A 5 Bシートは 組 番・・・・・金額 B 1 B 2 B 3 B 4 B 5 のようになっていて
金額シートは A 1 1,000 A 4 2,000 B 2 3,000 B 5 4,000 のようになっています。
金額シートの金額を組と番号が一致するシートの金額にセットしたいのです。 上記の例では、以下の結果になります。 Aシートは 組 番・・・・・金額 A 1 1,000 A 2 A 3 A 4 2,000 A 5 Bシートは 組 番・・・・・金額 B 1 B 2 3,000 B 3 B 4 B 5 4,000
よろしくお願いします。
金額シートに[組]&[番]のKeyとなる列を作っておけば、 SUMIFでイケそうですね。
(白茶)
(白茶)さん ありがとうございます。 一応以下のように、作成してみましたが、各シートに固定値にすればセットされますが、 セーブした値では、セットされません。
これではセットされない 'Worksheets(シート).Cells(j, "AE").Value = curenjo1
'Worksheets(シート).Cells(j + 1, "AE").Value = curenjo2
こちらにするとセットされる Worksheets(シート).Cells(j, "AE").Value = 12345
Worksheets(シート).Cells(j + 1, "AE").Value = 67890
VBAは以下です。 基本的なことかもしれませんが、よろしくお願いします。
'*******************************************
'金額セット
'*******************************************
Sub enjyo_set(ByVal strsheetNM As String)
Dim j As Integer '行の添え字（３行～８１行まで１行おき）
Dim K As Integer '金額シートの列の添え字（最大５０件）
'組、番号のエリア
Dim strkumi As String 'クラス
Dim strban As String '番号
Dim strkumiw As String '各シートのクラス
Dim strbanw As String '各シートの番号
Dim curenjyo1 As Currency '金額１
Dim curenjyo2 As Currency '金額２
Dim シート As Long
On Error GoTo calc_enjyo_err
curenjyo1 = 0
curenjyo2 = 0
For K = 3 To 21 Step 2
strkumi = CStr(Worksheets(strsheetNM).Cells.Item(K, "A").Value) 'Aのセーブ
strban = CStr(Worksheets(strsheetNM).Cells.Item(K, "B").Value) 'Bのセーブ
curenjyo1 = CCur(Worksheets(strsheetNM).Cells.Item(K, "G").Value) '金額１のセーブ
curenjyo2 = CCur(Worksheets(strsheetNM).Cells.Item(K + 1, "G").Value) '金額２のセーブ
シート = 2
Do Until シート > 10
'セット処理
'--------------------------------------------------------------------
'各のシートに金額をセット（１→４０）
For j = 3 To 81 Step 2 '（１～４０）の検索とセット
strkumiw = CStr(Worksheets(シート).Cells(j, 1).Value)
strbanw = CStr(Worksheets(シート).Cells(j, 2).Value)
curenjyo1 = CCur(Worksheets(strsheetNM).Cells.Item(K, "G").Value)
curenjyo2 = CCur(Worksheets(strsheetNM).Cells.Item(K + 1, "G").Value)
If strkumi = strkumiw And strban = strbanw Then
'Worksheets(シート).Cells(j, "AE").Value = curenjo1
'Worksheets(シート).Cells(j + 1, "AE").Value = curenjo2
Worksheets(シート).Cells(j, "AE").Value = 12345 '金額１セット
Worksheets(シート).Cells(j + 1, "AE").Value = 67890 '金額２セット
'MsgBox "curenjo1 = " + CStr(curenjo1) + " k = " + CStr(K)
Exit Do
End If
Next j
'MsgBox "シート = " + CStr(シート)
シート = シート + 1
Loop
'End If
'Next
Next K
Exit Sub
calc_enjyo_err:
MsgBox "errno" & Err.Number & ":" & Err.Description & vbcrlf & " ﾍﾙﾌﾟ " & Err.HelpContext
'HelpContext
End Sub
あ、あの・・・ SUMIFは・・・?
話が飛び過ぎですね。誤爆レスかと思った。 暗黙のダメ出しですか・・・?
まあ、それはさておき。
上記のコードでテストしたけど、エラー発生しなかったですよ。 強いて言えば、テスト用に作成したブックでは、 SheetのIndexが1～10なのに対して、 ご提示のコードでは2～10ですから、Sheet(1)に相当するシートが 突合せ対象から外れた事くらいですかね。
シート上の都合か、データ固有の都合か、 原因は、そんなところじゃないのかなと思います。
あと、金額シートで「組」が2行ずつ並んでるからでしょうけど、 別に2行ずつ検査しなくても、連続で1つずつやっても一緒じゃない?
Sub Test1() '←このマクロをキックする。
Const Sh金額 As String = "金額" '金額シートのシート名
Const 組列 As Long = 1 '金額シートの「組」の列番号
Const 番列 As Long = 2 '金額シートの「番」の列番号
Const 金額列 As Long = 7 '金額シートの金額欄
Const sRow As Long = 3 'データの読込み開始行
Const eRow As Long = 22 'データの読込み終了行
Dim r As Long
Dim Key As String, Val As Currency
For r = sRow To eRow
With Worksheets(Sh金額)
Test2 .Cells(r, 組列) & .Cells(r, 番列), .Cells(r, 金額列)
End With
Next r
End Sub
Sub Test2(Key, Val)
Const 組列 As Long = 1 '各シートの「組」の列番号
Const 番列 As Long = 2 '各シートの「番」の列番号
Const 金額列 As Long = 31 '各シートの金額欄
Const sRow As Long = 3 'マッチング開始行
Const eRow As Long = 81 'マッチング終了行
Dim r As Long
Dim aSh As Worksheet
For Each aSh In Worksheets(Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J"))
For r = sRow To eRow
If aSh.Cells(r, 組列) & aSh.Cells(r, 番列) = Key Then
aSh.Cells(r, 金額列) = Val
Exit Sub
End If
Next r
Next
End Sub
(白茶)
(白茶)様 ありがとうございます。 SUMIFは・・・どうしたらいいかわからなかったので、すいません。 完璧で分かりやすいプログラムを作成してもらい、ほぼそのままで使用しています。 すごく分かりやすいプログラムをありがとうございました。 あつかましいですが、またなにかあればよろしくお願いします。
お世話になります。 同様の処理で、各シート(A～J)に元名簿から氏名をセットしたいのですが、 「アプリケーション定義またはオブジェクト定義のエラーです。」になります。 元名簿は、組、番号、氏名、・・・の形式です。 プログラムは以下ですが、simei2 .Cells(r, 組列) & .Cells(r, 番列), .Cells(r, 氏名列) のところでエラーになります。 なぜでしょうか？
Sub simei1() '＜元名簿から名前を各シートにセット＞
Const Sh元名簿 As String = "元名簿" '元名簿シートのシート名
Const 組列 As Long = 1 '元名簿シートの「組」の列番号
Const 番列 As Long = 2 '元名簿シートの「番」の列番号
Const 氏名列 As String = 3 '元名簿シートの氏名
'Const 氏名列 As String = 10 '元名簿シートの氏名
Const sRow As Long = 2 'データの読込み開始行
'Const eRow As Long = 343 'データの読込み終了行
Const eRow As Long = 100 'データの読込み終了行
Dim r As Long
Dim Key As String, val As String
For r = sRow To eRow
With Worksheets(Sh元名簿)
simei2 .Cells(r, 組列) & .Cells(r, 番列), .Cells(r, 氏名列)
'MsgBox "氏名 = " + CStr(Cells(r, 氏名列))
End With
Next r
End Sub
Sub simei2(Key, val)
Const 組列 As Long = 1 '各シートの「組」の列番号
Const 番列 As Long = 2 '各シートの「番」の列番号
Const 氏名列 As String = 3 '各シートの氏名欄
Const sRow As Long = 3 'マッチング開始行
Const eRow As Long = 81 'マッチング終了行
Dim r As Long
Dim aSh As Worksheet
For Each aSh In Worksheets(Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J"))
For r = sRow To eRow Step 2
If aSh.Cells(r, 組列) & aSh.Cells(r, 番列) = Key Then
aSh.Cells(r, 氏名列) = val
Exit Sub
End If
Next r
Next
End Sub
Const 氏名列 As String を Const 氏名列 As Long に訂正してみて下さい。
(白茶)
(白茶)師匠様 お世話になります。 As String を As Long にしたら、エラーはなくなりましたが、 氏名がセットされません。Sh元名簿には、名前をいれているのですが・・・ PGというより、こちらの環境の問題でしょうね。たぶん もう少し、見直してみます。
各シート(A～J)がアティブになった時、simei1を起動しているのですが、 問題ないでしょうか？
>各シート(A～J)がアティブになった時 でもかまいませんよ。
私が言いたかったのは、
Const 氏名列 As String = 3 '元名簿シートの氏名 Const 氏名列 As String = 3 '各シートの氏名欄
が、
.Cells(r, 氏名列) aSh.Cells(r, 氏名列) = val
の処理時に、実質
.Cells(2, "3") aSh.Cells(3, "3") = val
で、「そんな番地のセル分かんね～ょ・・・」 とアプリケーションがブーたれているのではないでしょうか? という事です。
(白茶)
(白茶)様 了解です。 ありがとうございます。 simei2 .Cells(r, 組列) & .Cells(r, 番列), .Cells(r, 氏名列) で 氏名を表示 MsgBox "名簿氏名 = " + CStr(Cells(r, 氏名列)) したら、各シート(A～J)の氏名が表示されます。 そのためにセットされないと思われるのですが、 なぜ元名簿の氏名が表示されないのでしょうか？
MsgBox "名簿氏名 = " + CStr(Cells(r, 氏名列)) ↓ MsgBox "名簿氏名 = " + CStr(.Cells(r, 氏名列))
の違いでしょうかね・・・? Withブロック内の話ですから。
(白茶)
(白茶)様 ありがとうございました。 解決しました。
Const 氏名列 As Long = 3 '各シートの氏名欄 のLong がいじくっているうちに Long = 31 とかになっていて、別の個所にセットされていました。
申し訳ありませんでした。
追加の処理ですが、A～jの組、番の金額を判定して、条件に合えば、名簿シートの住所等より 宛名ラベルを差し込み印刷で印字したいのですが、With Worksheets(ash)の個所で 「型が一致しません」がでます。 何が原因なのか教えていただけないでしょうか？ よろしくお願いします。ラベルは１０人編集したら印刷しようとしています。
'------------------------------------------------------------------------------------
' 各シートを検索し、金額条件にあえば元名簿を参照し、ラベル印刷する
' ラベルは１０人編集したら印刷する
'------------------------------------------------------------------------------------
Sub label_PRT01()
Const 組列 As Long = 1 '各シートの「組」の列番号
Const 番列 As Long = 2 '各シートの「番」の列番号
Const 金額 As Long = 29 '各シートの「金額」の列番号
Const sRow As Long = 3 'マッチング開始行
Const eRow As Long = 81 'マッチング終了行
MsgBox "ラベルを印刷します。ラベルをセットしてください。"
Dim idx1 As Long '１シートの件数（１０枚）
idx1 = 0
Dim r As Long
Dim ash As Worksheet
For r = sRow To eRow Step 2
Dim key As String, val As Currency, val1 As Integer
For Each ash In Worksheets(Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J"))
If ash.Cells(r, 金額列) + ash.Cells(r + 1, 金額列) < 0 Then
idx1 = idx1 + 1
With Worksheets(ash) ← 「型が一致しません」
label_PRT02 .Cells(r, 組列) & .Cells(r, 番列), .Cells(r, 金額列), .idx1
End With
End If
Next
MsgBox "---PRINTOUT TEST ---"
'myTem.PrintOut
Application.DisplayAlerts = False
myTem.Delete
Application.DisplayAlerts = True
idx1 = 0
Next
End Sub
Sub label_PRT02(key, val, val1) '------------------------------------------- '住所ラベルの差し込み印刷 テスト '-------------------------------------------
Dim y As Long '縦
Set myTar = Worksheets("名刺ラベル")
Set myDat = Worksheets("元名簿")
myArr = myDat.Range("A2:T343")
myTar.Copy after:=myDat Set myTem = ActiveSheet myTem.Name = "temporary"
For y = sRow To eRow
With Worksheets(Sh元名簿)
If Sh元名簿.Cells(y, 組列) & Sh元名簿.Cells(y, 番列) = key Then
'名前セット
target_name = "nm" & idx1
myTem.Cells.Find(target_name).Value = myArr(y, 13)
'住所セット
target_name = "ad" & idx1
myTem.Cells.Find(target_name).Value = myArr(y, 14)
'郵便№セット
target_name = "yubin" & idx1
myTem.Cells.Find(target_name).Value = myArr(y, 20)
End If
End With
Next
End Sub
Worksheets(ash.name) 変数のデータ型が何なのか、変数を利用するプロパティにセットすべきなのは どんな型の値なのか、意識しないと、いつまでたっても同じような エラーに突き当たります。 (みやほりん)(-_∂)b
(みやほりん)(-_∂)b さん ありがとうございます。 慎重に意識しながら作成していきます。
じっくり見ると ＞ If ash.Cells(r, 金額列) + ash.Cells(r + 1, 金額列) < 0 Then これで、ashシートのそれぞれのセルのデータを取得出来るのですよね。
＞label_PRT02 .Cells(r, 組列) & .Cells(r, 番列), .Cells(r, 金額列), .idx1
~ashシートの ~ashシートの ~ashシートの
なら
label_PRT02 ash.Cells(r, 組列) & ash.Cells(r, 番列), ash.Cells(r, 金額列), idx1
もしもこれを With でまとめるなら
With ash
label_PRT02 .Cells(r, 組列) & .Cells(r, 番列), .Cells(r, 金額列), idx1
End With
と言う事になりませんか？
この行だけ With でまとめるのはどうかと思いますが。。。
それから、この辺りも良く分かりません。 ＞ With Worksheets(Sh元名簿) ＞ If Sh元名簿.Cells(y, 組列) & Sh元名簿.Cells(y, 番列) = key Then
(HANA)
(HANA)さん ご指摘ありがとうございます。
基本的には、各シートより条件に合ったデータを名簿シートを参照してラベル(10枚)を印刷
したいだけなのですが・・・・・ うまくいきません。
どなたか方向性だけでも教えていただけないでしょうか？
その他の疑問は以下です。
(1)のPrintOutは、label_PRT02 でないといけないでしょうか？
(2)の処理でA3,B3,C3,D3-----,A4,B4,C4,D4----のように処理されますが、
A3,A4,A5-----,B3,B4,B5-----のように処理するのはどのような処理をしたらいいでしょうか？
(3)でIDX1が10の時印字しますが、終了時の印字はどのようにすればいいでしょうか？
現在のPGは以下です。
よろしくお願いします。
'------------------------------------------------------------------------------------
' ラベルを印刷するため、各シートの未納額ありの生徒より元名簿を参照し、ラベル印刷する
'------------------------------------------------------------------------------------
Sub label_PRT01()
Const 組列 As Long = 1 '各シートの「組」の列番号
Const 番列 As Long = 2 '各シートの「番」の列番号
Const 未納列 As Long = 29 '各シートの「未納合計」の列番号
Const sRow As Long = 3 'マッチング開始行
Const eRow As Long = 81 'マッチング終了行
MsgBox "ラベルを印刷します。ラベルをセットしてください。"
Dim IDX1 As Long '１シートの件数（１０枚）
IDX1 = 0
Dim r As Long
Dim ash As Worksheet
For r = sRow To eRow Step 2
Dim key As String, val As Currency, val1 As Long
For Each ash In Worksheets(Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J")) '----- (2)
If ash.Cells(r, 未納列) + ash.Cells(r + 1, 未納列) > 0 Then
IDX1 = IDX1 + 1
If IDX1 > 10 Then 'IDX1が10以上なら印刷 ----- (3)
MsgBox "---PRINTOUT TEST ---"
'myTem.PrintOut '----- (1)
Application.DisplayAlerts = False
myTem.Delete
Application.DisplayAlerts = True
IDX1 = 1
End If
'キーとIDX1を渡しlabel_PRT02 でラベルにセットする
With Worksheets(ash.Name)
label_PRT02 .Cells(r, 組列) & .Cells(r, 番列), .Cells(r, 未納列), IDX1 '----- (4)
End With
End If
Next
Next
End Sub
====================================================================================== Sub label_PRT02(key, val, val1) '------------------------------------------- '住所ラベルの差し込み印刷 '-------------------------------------------
Const Sh元名簿 As String = "元名簿" '元名簿シートのシート名 Const 組列 As Long = 1 '元名簿シートの「組」の列番号 Const 番列 As Long = 2 '元名簿シートの「番」の列番号 Const 保護者名列 As Long = 13 '元名簿シートの保護者名
Const sRow As Long = 2 'データの読込み開始行 Const eRow As Long = 343 'データの読込み終了行
Dim IDX1 As Long '１シートの件数(MAX=10) Dim y As Long '縦
IDX1 = val1 'label_PRT01 から渡されたval1をIDX1にセット
Set myTar = Worksheets("名刺ラベル") '名刺ラベルのエクセルシート
Set mydat = Worksheets("元名簿") '元名簿のエクセルシート
myArr = mydat.Range("A2:T343") 'データの範囲
myTar.Copy after:=mydat '名刺ラベルのエクセルシートをコピー Set myTem = ActiveSheet myTem.Name = "temporary"
MsgBox "PRT02 IDX1 = " + CStr(IDX1) 'IDX1は1,2,3・・・・と表示され受け渡されていると思われる
For y = sRow To eRow
With Worksheets(Sh元名簿)
If mydat.Cells(y, 組列) & mydat.Cells(y, 番列) = key Then '組と番が一致した時にセット
'MsgBox "KEY = " + CStr(key)
'保護者名セット
target_name = "nm" & IDX1
myTem.Cells.Find(target_name).Value = myArr(y, 13)
'住所セット
target_name = "ad" & IDX1
myTem.Cells.Find(target_name).Value = myArr(y, 14)
'郵便№セット
target_name = "yubin" & IDX1
myTem.Cells.Find(target_name).Value = myArr(y, 20)
End If
End With
Next
End Sub
人のコードを読むのは得意では無いので
＞うまくいきません。 とは、どの様になるのでしょう？
そもそも、シートはいくつ有ってそれぞれどの様に成っているのですか？ 最初のご説明時の ＞ブック内にシートA,B,C,D,E,F,G,H,I,J と金額のシートがあり から、シート数も増えている様ですが。
基本的には、PrintOutするのは、印刷するシートだと思いますよ。
それから、今は
＞ For r = sRow To eRow Step 2
先頭行から最終行迄のループ処理
の中で
＞For Each ash In Worksheets(Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J"))
A→Jのシートの処理
が行われているので
3行目に付いて
Aシートは・・・Bシートは・・・Cシートは・・・
4行目に付いて
Aシートは・・・Bシートは・・・Cシートは・・・
と成っています。
A→Jのシート処理の中で、sRow→eRow の処理をする事にすれば Aシートについて 2行目は・・・3行目は・・・4行目は・・・5行目は・・・ Bシートについて 2行目は・・・3行目は・・・4行目は・・・5行目は・・・ の様に処理が進んでいくと思います。
また、最後まで処理が済んだ時に IDX1 が 10で無かったら印刷され無いのなら 最後まで処理が済んだ時に IDX1 の値を確認して、10で無かったら 印刷することにすれば、最後まで印刷されるのではないかと思います。
全体的な流れは見ていませんので、一つの方向性 と言う事で。
(HANA)
(HANA)さん 早々にご回答をありがとうございます。
うまくいかないのは、myTem.Name = "temporary"のところで、
１．実行時エラー1004(シートの名前を他のシート・・・・同じ名前に変えることはできません)
となり、コメント('myTem.Name = "temporary")にすると実行されますが、シートが増え続けます。
(宛名シート(2), 宛名シート(3)・・・・・というように）
２．そして各シートには、宛名は１つずつしかセットされていません。
label_PRT01 でなく label_PRT02 の中で PrintOut しないと受け渡しの関係でうまくいかないの
でしょうか？
その他は、ご指摘のように変更して実行してみます。 お手数をお掛けして申し訳ありません。
＞'名刺ラベルのエクセルシートをコピー は、いつ行いたいのでしょう？
現在のコードですと、label_PRT01コードのなかで
'キーとIDX1を渡しlabel_PRT02 でラベルにセットする
With Worksheets(ash.Name)
label_PRT02 .Cells(r, 組列) & .Cells(r, 番列), .Cells(r, 未納列), IDX1 '----- (4)
End With
が実行されるたびに、label_PRT02 の中のコピーも実行されますよね？
処理の流れを言葉で説明してもらえませんか？ 「宛名シート」が増えてしまうのは、意図して居ないと言う事ですが どのタイミングでどうなるのが意図した動きなのでしょう？
データが10個埋まったタイミングでコピー（新しい印刷用シート）を作成し 前のデータが埋まったシートが消えないようにしようと思っているのか それとも、処理を開始した最初にコピーを作って、処理が終わったら そのシートを削除して、元のシートはつつかない事にしようと思っているのか 或いは、それ以外の事を意図して、どうなれば良い・・・？
＞ そもそも、シートはいくつ有ってそれぞれどの様に成っているのですか？ のお返事はどうでしょう？ A～Jの未納の列には、既に未納金額が入っているのですよね？ 元名簿は何の情報が入ったシートですか？ 名刺ラベルは、何の情報が入ったシートですか？ それぞれ、どの様なレイアウトでどのセルに何が入力されていますか？
それから、使用して居られる変数も整理した方が良さそうに思いますが。。。
(HANA)
(HANA)さん ご指示、ありがとうございます。
シートの概要と処理の流れは以下のようになります。
1.まず、今回使用するシートですが、以下の通りです。
・各シート(A～J) ・・・・・１、２行は見出しで以下２行で１人の
情報があります。
項目は、組、番号、氏名・・・・・未納額等があり、未納額には１年間の
未納が計算されています。４０人がMAXなので82行がMAXでAシート～
Jシートまであります。
・元名簿・・・・・１行が見出しで１行で１明細です。
項目は、組、番号、氏名、保護者名・・・住所・・・郵便番号等があります。
・名刺ラベル・・・・・郵便番号と住所と保護者名を２列×５で並べたEXCELシート
差し込み印刷のため項目をYUBIN1,AD1,MN1～YUBIN10,AD10,MN10として
配置しています。
２．まず各シートをAの1番からJの40番まで順によんで、未納であれば、組、番号
をキーとして、元名簿から一致する、保護者名、住所、郵便番号を名刺ラベル
の１から順番にセットしていき、１０までセットしたら名刺ラベルを１枚印字
し、 次の１からのセットしていきます。
最後は終了時点で印字します。
別に督促状を印刷して封筒にはる貼るための宛名に使用します。
したがって、名刺ラベルの元のシートのみ残っていれば、印刷したシートは
不要です。
名刺ラベルのエクセルシートのコピーは、実行途中に停止したことを考えて
temporaryにコピーしようとしています。（参照した本によれば）
処理の概要は以上です。
お手数をおかけしますが、よろしくお願いします。
各シートA～JのA列は、その行の最終行まで入力が有りますか？ それとも、二行おきに入力があって 表の最終行は、入力が有る最終行+1行 でしょうか？
＞郵便番号と住所と保護者名を２列×５で並べたEXCELシート 具体的なセル番地を教えて下さい。
＞差し込み印刷のため項目をYUBIN1,AD1,MN1 AD1,MN1がセルの結合がしてあって、YUUBIN1と入力が有るのでしょうか？ 住所と保護者名は何処の列でしょう？
＞～YUBIN10,AD10,MN10として これだと、1～10行にデータを入力する様に思えますが。。。 この場所にまとめて一覧を作成して於いて、実際のレイアウトへは 「=」等で参照しているのでしょうか？
(HANA)
あっ ＞差し込み印刷のため項目をYUBIN1,AD1,MN1～YUBIN10,AD10,MN10として この AD1,MN1,AD10,NM10 ってセル番地じゃないんですね。 セル番地かと思ってました。。。
空いたスペースに上から順に詰めて表示して それぞれのセルには数式で参照する事にすると 面倒な計算をしなくて済むので 簡単じゃないかと思いますが。。。 最初に数式を入れるのは面倒ですが。
取りあえず、名刺ラベルシートのA:D列を使用します。 [A] [B] [C] [D] [1] 郵便No 住所 保護者氏名 [2] 1 [3] 2 [4] 3 [5] 4 [6] 5 [7] 6 [8] 7 [9] 8 [10] 9 [11] 10 実際のラベルの配置はE列以降に作成し 印刷範囲を設定しておいて下さい。
'------
Sub label_PRT01()
Const 組列 As Long = 1 '各シートの「組」の列番号
Const 番列 As Long = 2 '各シートの「番」の列番号
Const 未納列 As Long = 29 '各シートの「未納合計」の列番号
Const sRow As Long = 3 'マッチング開始行
Dim IDX1 As Long '１シートの件数（１０枚）
Dim r As Long
Dim ash As Worksheet
Dim key As String, val As Currency, val1 As Long
MsgBox "ラベルを印刷します。ラベルをセットしてください。"
'temporaryシートが既に有ったら削除
On Error Resume Next
Application.DisplayAlerts = False
Sheets("temporary").Delete
Application.DisplayAlerts = True
On Error GoTo 0
'名刺ラベルのエクセルシートをコピーし、シート名を tempotary に変更
Worksheets("名刺ラベル").Copy after:=Worksheets("元名簿")
ActiveSheet.Name = "temporary"
'ラベル作成 ＆ 印刷
For Each ash In Worksheets(Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J"))
With ash
eRow = .Range("A" & Rows.Count).End(xlUp).Row
For r = sRow To eRow Step 2
If .Cells(r, 未納列) + .Cells(r + 1, 未納列) > 0 Then
IDX1 = IDX1 + 1
'キーとIDX1を渡しlabel_PRT02 でラベルにセットする
label_PRT02 .Cells(r, 組列) & .Cells(r, 番列), .Cells(r, 未納列), IDX1
'IDX1が10なら印刷
If IDX1 = 10 Then
'ActiveSheet.PrintOut
ActiveSheet.PrintPreview
Range("B2:D11").ClearContents
IDX1 = 0
End If
End If
Next
End With
Next
'10個埋まっていなくて印刷されていなかった場合印刷
If 0 < IDX1 And IDX1 < 10 Then
'ActiveSheet.PrintOut
ActiveSheet.PrintPreview
End If
'temporaryシートの削除
Application.DisplayAlerts = False
Sheets("temporary").Delete
Application.DisplayAlerts = True
End Sub
'====================================================================================== Sub label_PRT02(key, val, val1) '------------------------------------------- '住所ラベルの差し込み印刷 '------------------------------------------- Const Sh元名簿 As String = "元名簿" '元名簿シートのシート名 Const 組列 As Long = 1 '元名簿シートの「組」の列番号 Const 番列 As Long = 2 '元名簿シートの「番」の列番号 Const 保護者名列 As Long = 13 '元名簿シートの「保護者名」の列番号 Const 住所列 As Long = 14 '元名簿シートの「住所」の列番号 Const 郵便No列 As Long = 20 '元名簿シートの「郵便№」の列番号
Const sRow As Long = 2 'データの読込み開始行
Dim IDX1 As Long '１シートの件数(MAX=10) Dim y As Long '縦 Dim myArr As Variant '元名簿シートのデータを取り込む
IDX1 = val1 'label_PRT01 から渡されたval1をIDX1にセット
With Worksheets(Sh元名簿)
eRow = .Range("A" & Rows.Count).End(xlUp).Row
myArr = .Range("A1:T" & eRow).Value
End With
For y = sRow To eRow
If myArr(y, 組列) & myArr(y, 番列) = key Then '組と番が一致した時にセット
'保護者名セット
Cells(IDX1 + 1, 4).Value = myArr(y, 保護者名列)
'住所セット
Cells(IDX1 + 1, 3).Value = myArr(y, 住所列)
'郵便№セット
Cells(IDX1 + 1, 2).Value = myArr(y, 郵便No列)
Exit For
End If
Next
End Sub
'------
＞＞それぞれのセルには数式で参照する事にすると に関しては、こちらと同じ様な作りです。 [[20091222113511]] 『店コード別に印刷』（初心者マーク）
直接配置していく場合は どの様に配置されているのか教えて下さい。 また、最初からデータがセットされていて データが消えると困るセルが有る場合は それも教えて下さい。
(HANA)
(HANA)さん ありがとうございます。 親身に対応していただいて感謝しています。 各シートは A B C D E F G H 1 組 番号 氏名 性別 ４月 ５月 ・・・・・未納額 2 区分 金額 区分 金額 ・・・・ 3 A 1 NNN 2 10,000 10,000 ・・・・ 50,000 4 5 A 2 NNN 1 10,000 10,000 0 6 ・ ・ 80 A 40 のようになっいて、だいたい番号は34ぐらいまでで有効データは、 性別の有無で判断しています。 以下B～Jのシートも同様です。
名刺ラベルのEXCELシートは、
〒 YUBIN1 | 〒 YUBIN2
|
AD1 | AD2
|
NM1 様 | NM2 様
|
--------------------------------------------------
|
〒 YUBIN3 | 〒 YUBIN4
|
AD3 | AD4
|
NM3 様 | NM4 様
|
--------------------------------------------------
のように名前を配置しています。ご指摘のように番地は意識せず、「＝」で参照しています。
元名簿シートは、
A B J M(=13) N(=14) T(=20)
2 組 番 保護者名 住所 郵便番号
3 A 1 あああああ ○○市○○ 999-9999
4 A 2 いいいいい ○○市○○ 999-9999
5 ・ ・
40 B 1 ううううう ○○市○○ 999-9999
・ ・
・ ・
J 1
343 J 34
のようになっいてA～Jが１つのシートになっています。
したがって以下でセットするようにしています。
For y = sRow To eRow
With Worksheets(Sh元名簿)
If mydat.Cells(y, 組列) & mydat.Cells(y, 番列) = key Then '組と番が一致した時にセット
'保護者名セット
target_name = "nm" & IDX1
myTem.Cells.Find(target_name).Value = myArr(y, 13)
'住所セット
target_name = "ad" & IDX1
myTem.Cells.Find(target_name).Value = myArr(y, 14)
'郵便№セット
target_name = "yubin" & IDX1
myTem.Cells.Find(target_name).Value = myArr(y, 20)
End If
End With
Next
名刺ラベルのEXCELシートは上記の項目を配置したシートのみで、データがセット されているセルはありません。
お手数をおかけします。
えっと。。。 ＞ご指摘のように番地は意識せず、「＝」で参照しています。 一寸良く分かりません。 どこかに一覧が有るのなら、検索する必要はなさそうですが。。。 「〒 YUBIN1」「AD1」「NM1 様」「〒 YUBIN3 」「〒 YUBIN2」 は、何処のセルを「＝」で参照しているのですか？ 或いは、何処のセルに有るのですか？
また、私が作ったコードは、どの様な動きをしましたか？ 上手く行かない所は直して行かないといけませんし ラベルのレイアウトだけが希望通りに成らないなら その部分を重点的に変更すれば良いと思いますので 結果を教えていただきたいのですが。
あれ？ ＞ 元名簿シートは、 ＞ A B J M(=13) N(=14) T(=20) ＞2 組 番 保護者名 住所 郵便番号 ＞ のようになっいてA～Jが１つのシートになっています。 A～J列がこのシートにあって、M～T列は別のシートに有るのですか。。。？
(HANA)
(HANA)さん お世話になります。ちょっと説明不足でした。
excelの差し込み印刷を行っているため、「名刺ラベル」のEXCELシートに
「YUBIN1」「AD1」「NM1」「YUBIN2」「AD2」「NM2」・・・・・「YUBIN10」「AD10」「NM10」
の文字列を入力しています。「〒」「様」は固定でシート上に作成しています。
例えばidx1が1なら
target_name = "nm" & IDX1 で target_name はidx1が1のため nm1 になります。
myTem.Cells.Find(target_name).Value = myArr(y, 13) は、
→ myTem.Cells.Find(nm1).Value = myArr(y, 13) となり
Findにより「名刺ラベルシート」のnm1 セルを探し、そのセルに myArrのデータ、
つまり「元名簿」の(y, 13)の 保護者名を入力するようになっているようです。
（excel VBAの差し込み印刷の箇所を参考にしました）
作成していただいたコードは、順番もA1,A2,A3・・・・・B1,B2・・・のように思った通りに また10明細ごとに、また終了も正しく出力されました。
説明不足でした。「元名簿」は
[A] [B] ・・・・・ [M] [N] [T] ←これは列です。
[1] 組 番 保護者名 住所 郵便番号
[2] A 1 あああああ ○○市○○ 999-9999
[3] A 2 いいいいい ○○市○○ 999-9999
[4] ・ ・
[35] B 1 ううううう ○○市○○ 999-9999
・ ・
・ ・
J 1
[343] J 34
のようになっていてA～T列は同じシートにあります。
後は「名刺ラベル」で指定した「YUBIN1」「AD1」「NM1」「YUBIN2」「AD2」「NM2」・・・・・ の箇所に、「元名簿」の内容がセットされればＯＫになります。
現在載せて居られるコードがどう言ったコードになっているかは 分かっていると思います。 しかし、住所などを入れる場所は規則的に並んでいると思いますので 文字を検索するのは非効率的だと思います。
また、現在の方法を考えていった場合 次のラベルを印刷するための準備として 「YUBIN1」「AD1」「NM1」「YUBIN2」「AD2」「NM2」 等の文字列のセットが必要になりますし 例えば最後に8件しか無かった場合 9,10枚目のラベルの該当部分には 「YUBIN9」「AD9」「NM9」「YUBIN10」「AD10」「NM10」 と言う文字が残ったまま印刷されることになります。 白紙のままで有れば、別の機会に使用することが出来ますが これらの文字が既に印刷されていたら、使えませんよね。
ですから、その部分の仕組みは考え直した方が良いと思います。
＞「〒」「様」は固定でシート上に作成しています。 これに関しても、固定で作成しておくのではなく データが有ったときに初めて表示される様にしておくのが 良いのではないかと思います。
現在のご説明までで、名刺ラベルシートに関する セル番地のみが不明ですので教えて下さい。
それからレイアウトがまだ変わってしまう可能性が有るのなら 「数式を入れておいてはどうでしょう？」 と言う提案もしていますが、どうでしょう？
(HANA)
(HANA)さん ありがとうございます。了解しました。 変わる可能性はあります。 したがってご指摘のように仕組みを変えたいと思います。 「名刺ラベル」はA4に印刷します。セル位置は以下で、横２、縦５定義しています。
-----------------------------------------------------------------
|
B3 C3～E3 | L3 M3～O3
|
|
B5～H5 | L5～R5
|
|
|
C8～F8 H8 | M8～P8 R8
|
----------------------------------------------------------------
|
B14 C14～E14 | L14 M14～O14
|
|
B16～H16 | L16～R16
|
|
|
C19～F19 H19 | M19～P19 R19
|
----------------------------------------------------------------
B3は「〒」、C3～E3はセル結合して、「YUBIN1」 B5～H5は「AD1」、C8～F8は「NM1」、H8は「様」で以下同様です。
「数式をいれる」とゆうのは、セルに入れるのでしょうか？
> どなたか方向性だけでも教えていただけないでしょうか？
サンプルファイルを作って、以下のようなところで、シートを公開してはいかがでしょうか？ 容量無制限の無料オンラインストレージ firestorage http://firestorage.jp/ 当然セルの値などの内容は、ダミーにしておく必要があります。 ただし、大事なのは、シートの名前、セル位置になります。
私は、ここに公開して、ファイルを見ていただいて教えていただき、比較的早くに解決に至ったことがあります。
(とおりすがり)
配置は分かりました。有難う御座います。
現在コードは、B2:D11にデータを書き出して居ますが その配置になるように コード内で計算してセル位置を算出し C3～E3,B5～H5,C8～F8 の様に点在させて書き出す事は可能です。 また、「〒」や「様」に関しても名前などを書き出す時に 一緒にセットする事にすることは出来ます。
しかし、コード内で直接この作業を行った場合 書き出すセルの位置を少し変更したいと思った場合 コードの修正が必要になってきます。
例えば、マクロは常にB2:D11にデータを書き出し（ココは印刷しない） 実際に印刷する範囲「C3～E3,B5～H5,C8～F8」には数式を入れておいて B2:D11の範囲から思った場所へデータを参照してもらっておくと レイアウトの変更時にコードを変更する必要が無くなります。
＞変わる可能性はあります。 したがってご指摘のように仕組みを変えたいと思います。 私が「仕組みを変えた方が良い」と言っているのは 変わる可能性が有るかどうかに依っているわけでは有りませんが その辺りは正しく伝わっていますか？ 似たような話が出ているので、上手く伝わっているか不安なのですが レイアウトが変わる可能性が有るのなら 私は、数式で参照する仕組みにして於かれるのが良いと思います。
また、コードを載せた時に一緒に こちらの過去ログも載せましたが 見てもらっていますか？ [[20091222113511]] 『店コード別に印刷』（初心者マーク）
この過去ログでも、 マクロがコードを書き出す場所が MAINシートのB2:C8 実際に印刷したいレイアウトが有る場所は PRINT2シートの各セルで そこへは「=IF(MAIN!B2="","",JIS(MAIN!B2))」等の数式で参照 と言う作りにしてあります。
今回もこの様にされてはどうでしょう？
一度に沢山書くと、上手く伝わらない可能性が高い気がするので 私の主張を理解して頂いた上で、過去ログを参考に、このスレを もう一度読んでみてください。
＞実際のラベルの配置はE列以降に作成し ＞印刷範囲を設定しておいて下さい。 これがどう言った操作の事か伝わりますか？
(HANA)
(HANA)さん ありがとうございます。 ＞実際のラベルの配置はE列以降に作成し ＞印刷範囲を設定しておいて下さい。 一旦A～Dにデータを書き出し、レイアウトをE以降に作成しておいて A～Dのデータとの関連付の数式をレイアウトの項目に設定しておき、 レイアウトを印刷範囲にして印刷するということだと思いますが、 過去ログを参考にして理解してみます。
はい、その様にして頂ければ良いと思います。 「〒」マークは、G3セルに =IF(B2="","","〒") の式を入れてもらっても良いと思いますし H3セルの式を単純に参照するのではなく =IF(B2="","","〒 "&B2) の様に「〒」マークが付くように参照させても良いかもしれません。
メインのコードは、現在宛名シートを複製して使用するコードにしていますが 印刷範囲とは別の所でデータを書き出していくので コピーする必要は無くなると思いますし、 空きラベル部分に印刷したい物も有るかもしれませんので 少し変更してみます。
'------
Sub label_PRT01()
Const 組列 As Long = 1 '各シートの「組」の列番号
Const 番列 As Long = 2 '各シートの「番」の列番号
Const 性別列 As Long = 4 '各シートの「性別」の列番号
Const 未納列 As Long = 29 '各シートの「未納合計」の列番号
Const sRow As Long = 3 '各シートのマッチング開始行
Dim IDX1 As Long '１シートの件数（１０枚）
Dim r As Long
Dim ash As Worksheet
Dim key As String, val As Currency, val1 As Long
If MsgBox("ラベルを印刷します。" & vbLf & _
"ラベルをセットしてください。", vbOKCancel) = vbCancel Then
Exit Sub
End If
Sheets("名刺ラベル").Activate
'ラベル作成 ＆ 印刷
For Each ash In Worksheets(Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J"))
With ash
eRow = .Cells(Rows.Count, 性別列).End(xlUp).Row
For r = sRow To eRow Step 2
If .Cells(r, 未納列) + .Cells(r + 1, 未納列) > 0 Then
IDX1 = IDX1 + 1
'キーとIDX1を渡しlabel_PRT02 でラベルにセットする
label_PRT02 .Cells(r, 組列) & .Cells(r, 番列), .Cells(r, 未納列), IDX1
'IDX1が10なら印刷
If IDX1 = 10 Then
'ActiveSheet.PrintOut
ActiveSheet.PrintPreview
Range("B2:D11").ClearContents
IDX1 = 0
End If
End If
Next
End With
Next
'10個埋まっていなくて印刷されていなかった場合
If 0 < IDX1 And IDX1 < 10 Then
If MsgBox("空きラベルが有りますが印刷しますか？", vbYesNo) = vbYes Then
'ActiveSheet.PrintOut
ActiveSheet.PrintPreview
Range("B2:D11").ClearContents
Else
MsgBox IDX1 & "件は印刷されません。" & vbLf & _
"別途印刷を行ってください。"
End If
End If
End Sub
'------
(HANA)
(HANA)さん ありがとうございました！！！ 実際のラベルの配置をE列以降に作成し印刷範囲を設定して実行してみました。 １０個未満の制御も完璧にできました。また郵便番号、様もうまくいきました。 一人ではとてもできなかったと思います。 感謝しています。どうもありがとうございました。
お世話になります。
１年生のラベル印刷は、正常に出力されます。２年、３年に展開するために、
BOOKをそれぞれ作成し、「１年用」「２年用」「３年用」とした時、「２年用」「３年用」で
「インデックスが有効範囲にありません」のエラーになります。
シートもコードも全く同じです。
Worksheets("名刺ラベル").Copy after:=Worksheets("学年全体") でエラーになります。
原因がよくわからないので、教えていただけないでしょうか？
なおコードは以下で、パラメータで、発行日と学年と学期を渡しています。
よろしくお願いします。
'------------------------------------------------------------------
' ラベル印刷（各シートの判定）
' （各シートを判定する）
'------------------------------------------------------------------
Sub label_PRT01(hako, nen, ki)
'画面表示を更新しない Application.ScreenUpdating = False
Const 組列 As Long = 1 '各シートの「組」の列番号
Const 番列 As Long = 2 '各シートの「番」の列番号
Const 性別列 As Long = 4 '各シートの「性別」の列番号
Const 未納列 As Long = 29 '各シートの「未納合計」の列番号
Const 未納7列 As Long = 37 '７月未納の列番号
Const 未納12列 As Long = 39 '１２月未納の列番号
Const 未納2列 As Long = 40 '２月未納の列番号
Const Srow As Long = 3 'マッチング開始行
Dim idx1 As Long '１シートの件数（１０枚）
Dim r As Long
Dim ash As Worksheet
Dim key As String, val As Currency, val1 As Long
If MsgBox("ラベルを印刷します。" & vbLf & _
"ラベルをセットしてください。", vbOKCancel) = vbCancel Then
Exit Sub
End If
MsgBox "nen,ki = " + CStr(nen) + CStr(ki)
'temporaryシートが既に有ったら削除
On Error Resume Next
Application.DisplayAlerts = False
Sheets("temporary").Delete
Application.DisplayAlerts = True
On Error GoTo 0
'名刺ラベルのエクセルシートをコピーし、シート名を tempotary に変更
Worksheets("名刺ラベル").Copy after:=Worksheets("学年全体") '←ここでエラーになります
ActiveSheet.Name = "temporary"
'シートのロック解除
Worksheets("temporary").Unprotect
'ラベル作成 ＆ 印刷
For Each ash In Worksheets(Array ("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L"))
'For Each ash In Worksheets(Array("A", "B"))
With ash
Erow = .Cells(Rows.Count, 性別列).End(xlUp).Row
'eRow = .Range("A" & Rows.Count).End(xlUp).Row
For r = Srow To Erow Step 2
'--------------- 未納判定 ---------------
If ((ki = 1 And .Cells(r, 未納7列) + .Cells(r + 1, 未納7列) > 0) Or _
(ki = 2 And .Cells(r, 未納12列) + .Cells(r + 1, 未納12列) > 0) Or _
(ki = 3 And .Cells(r, 未納12列) + .Cells(r + 1, 未納12列) > 0)) Then
'--------------------------------------------------------------------------------------
idx1 = idx1 + 1
'キーとIDX1を渡しlabel_PRT02 でラベルにセットする
label_PRT02 .Cells(r, 組列) & .Cells(r, 番列), .Cells(r, 未納列), idx1
'IDX1が10なら印刷
If idx1 = 10 Then
'ActiveSheet.PrintOut
ActiveSheet.PrintPreview
'Range("E2").CurrentRegion.Resize(30, 10).PrintPreview
Range("B2:D11").ClearContents
idx1 = 0
End If
End If
Next
End With
Next
'10個埋まっていなくて印刷されていなかった場合印刷
If 0 < idx1 And idx1 < 10 Then
'ActiveSheet.PrintOut
ActiveSheet.PrintPreview
End If
'temporaryシートの削除
Application.DisplayAlerts = False
Sheets("temporary").Delete
Application.DisplayAlerts = True
'画面表示を更新する Application.ScreenUpdating = True
End Sub
'--------------------------------------------- '住所ラベルの項目セット (2010.01.19) '--------------------------------------------- Sub label_PRT02(key, val, val1)
Const Sh元名簿 As String = "元名簿" '元名簿シートのシート名 Const 組列 As Long = 1 '元名簿シートの「組」の列番号 Const 番列 As Long = 2 '元名簿シートの「番」の列番号 Const 保護者名列 As Long = 5 '元名簿シートの「保護者名」の列番号 Const 住所列 As Long = 7 '元名簿シートの「住所」の列番号 Const 郵便No列 As Long = 6 '元名簿シートの「郵便№」の列番号 Const Srow As Long = 2 'データの読込み開始行
Dim idx1 As Long '１シートの件数(MAX=10) Dim y As Long '縦 Dim myArr As Variant '元名簿シートのデータを取り込む
idx1 = val1 'label_PRT01 から渡されたval1をIDX1にセット
With Worksheets(Sh元名簿)
Erow = .Range("A" & Rows.Count).End(xlUp).Row
myArr = .Range("A1:T" & Erow).Value
End With
For y = Srow To Erow
If myArr(y, 組列) & myArr(y, 番列) = key Then '組と番が一致した時にセット
'保護者名セット
Cells(idx1 + 1, 4).Value = myArr(y, 保護者名列)
'住所セット
Cells(idx1 + 1, 3).Value = myArr(y, 住所列)
'郵便№セット
Cells(idx1 + 1, 2).Value = myArr(y, 郵便No列)
Exit For
End If
Next
End
＞「インデックスが有効範囲にありません」のエラーになります。
＞Worksheets("名刺ラベル").Copy after:=Worksheets("学年全体") でエラーになります。
この情報から考えやすいのは、シート名が違うパターンです。
シート名の前後に空白等入っていませんか？
現在のシートは一旦名前を変更して ちゃんと動くブック（１年生のブック？）からシートをコピーして データだけを貼り替えてみてはどうでしょう？
(HANA)
HANA さん ありがとうございました。 ちゃんと動くブックからシートをコピーして変更したら正常に動きました。 変更をそれぞれに追加していったため、どこかでおかしくなったのだと思います。
それとは別ですが、EXCELのVisual Basicの画面が１つになってしまったのですが、 標準画面（左上にプロジェクト、左下にプロパティ、右にコードが表示される）に戻す のはどうすればいいのでしょうか？ よろしくお願いします。
あ、それは私も苦手なんですよねぇ。。。
まず、ツール(T)→オプション(O)のドッキングタブを開いて 必要な所にチェックが付いているか確認して下さい。
それから、表示(V)から必要なウィンドウを表示させます。
VBEのウィンドウは最大化させておくと良いかもしれません。 ウィンドウの外まで移動して仕舞う事が無くなるので。 それと、コードを書くウィンドウも大きくしておくと良いかもしれません。 これは、移動した時の灰色の枠が見やすく成ると思うので。
後は、ドラッグ＆ドロップ なんです。。。
[プロジェクト-VBAProject ×] って所で左クリックしてそのまま左の方向へドラッグ。 すると、灰色の少し太い枠で位置が表示されながらドラッグ出来ます。 ウィンドウの端の方に行くと、細い枠で縦長に成ったり横長に成ったりします。 左端に行けば縦長に、上・下端に行くと横長に。 見にくいかも知れませんが、気を付けて見てもらえれば気づけると思います。
とにかく、枠が細くなった時に 指を離してみてください。
プロジェクトウィンドウと、オブジェクトウィンドウは 先に二つを上下にくっつけて於いて くっついた二つを、VBEの左端に持っていって くっつけるのが簡単かもしれません。
なかなか上手く行かないかもしれませんが 色んな所へ持っていって、変化を確認しながら コツを掴んでください。
(HANA)
HANA さん ありがとうございました。 最初のツール(T)→オプション(O)のドッキングタブを開いて 必要な所にチェックが付いているか確認で、 プロジェクト、プロＬティ、オブジェクトブラウザにチェックが なかったので、付けたらその時点で、直りました。 お手数をおかけしました。
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.