『複数シートにデータを転記する』（許斐） 職員の制服等貸し出し帳を別シートに転記する方法を教えてください。 形が複雑のために、マクロ自動登録できずに困っています。 過去検査で転記について調べてみましたが、分かりませんでした。。。。 1.[4]〜[18]行のデータはWorkbooks("book2.xls").Sheets("Sheet2") 2.[20]〜[25]行のデータはWorkbooks("book3.xls").Sheets("Sheet3") Workbooks("book1.xls").Sheets("Sheet1") [A] [B] [C] [D] [E] [F] [G] [H] [I] [J] [K] [L] [M] [4] ふりがな やまだはなこ 職員番号 00001 階級 A 所属 B [5] 氏名 山田花子 生年月日 2009/9/6 採用年月日 2009/9/6 [6] 項目名 日付1 日付2 日付3 項目名 日付1 日付2 日付3 項目名 日付1 日付2 日付3 [7] A服 H1.4.1 H19.10.31 A-1服 H18.12.15 A-2服 H18.12.15 [8] B服 H1.4.1 H19.10.31 B-1服 H1.4.1 B-2服 H1.4.1 [9] C服 H1.4.1 H19.10.31 C-1服 H1.4.1 C-2服 H1.4.1 [10] D服 H1.4.1 H19.10.31 D-1服 H1.4.1 D-2服 H1.4.1 [11] E服 H1.4.1 E-1服 H12.7.21 E-2服 H12.7.21 [12] F服 H1.4.1 F-1服 H18.2.17 F-2服 H18.2.17 [13] G服 H18.3.28 G-1服 H18.10.31 G-2服 H18.10.31 [14] H服 H18.5.26 H-1服 H5.12.24 H-2服 H5.12.24 [15] I服 H9.6.13 I-1服 H1.4.1 H19.10.31 I-2服 H1.4.1 H19.10.31 [16] J服 J-1服 H1.4.1 J-2服 H1.4.1 [17] K服 K-1服 H18.5.26 K-2服 H18.5.26 [18] 備考 L服 [19] [20] サイズ [21] 頭 1 上衣丈 6 ｷｬｯﾌﾟ 11 A服 15 [22] 首 2 ウエスト 7 ｼｬﾂ 12 B服 16 [23] 胸囲 3 尻廻り 8 上着 13 C服 17 [24] 肩幅 4 ｽﾞﾎﾞﾝ丈 9 ｽﾞﾎﾞﾝ 14 D服 18 [25] 袖丈 5 靴 10 上手く説明できているか不安ですが、、よろしくお願いたします。 ---- ４行目から始まる表と２０行目から始まる表は かならず４行目と２０行目から始まるのですか？ もし、決まっているのなら範囲取得はCurrentRegionとかで簡単に 取得できると思いますが （ｍｏｍｏ） ---- 具体的には、こんな感じで範囲は取得できます。 With Columns("A:A") Set r = .ColumnDifferences(.SpecialCells(xlCellTypeBlanks).Cells(1)).Areas For i = 1 To r.Count r.Item(i).CurrentRegion.Select MsgBox i & "つ目の範囲は：" & r.Item(i).CurrentRegion.Address Next i End With （ｍｏｍｏ） ---- momoさん 返信ありがとうございます。 >かならず４行目と２０行目から始まるのですか？ はいそうです。 CurrentRegionは空欄から空欄のセルの範囲を習得？ 下記の表のように転記されませんでした。 縦の列を転記終了後に次の項目の列のデータを転記させることは可能でしょか？ ("book2.xls").Sheets("Sheet2") のレイアウト [A] [B] [C] [D] [E] [F] [G] [H] [I] [J] [K] [L] [M] [N] [O] [P] [Q] [R] [S] [T] [U] [V] [W] [X] [Y] [Z] [AA] [AB] [AC] [AD] [AE] [AF] [AG] [AH] [AI] [AJ] [AK] [AL] [AM] [AN] [AO] [AP] [AQ] [AR] [AS] [AT] [AU] [AV] [AW] [B] [A] [B] "職員 番号" 氏名 ふりがな 階級 生年月日 年齢 採用年月日 "勤続 年数" 所属 A服 B服 C服 D服 E服 F服 G服 H服 I服 J服 K服 A-1服 B-1服 C-1服 日付1 日付2 日付3 [2] 00001 山田花子 やまだはなこ A 2009/9/6 2009/9/6 B H1.4.1 H19.10.31 H1.4.1 H19.10.31 H1.4.1 H19.10.31 H1.4.1 H19.10.31 H1.4.1 H1.4.1 H18.3.28 H18.5.26 H9.6.13 H18.12.15 H1.4.1 H1.4.1 Workbooks("book3.xls").Sheets("Sheet3")　のレイアウト [A] [B] [C] [D] [E] [F] [G] [H] [I] [J] [K] 職員番号 氏名 ふりがな 頭 首 胸囲 肩幅 袖丈 上衣丈 ウエスト 尻廻り ズボン丈･･･････････････ ---- という事は場所は固定なのですから 単純に１つ１つコピーしていくのをマクロ記録を取っても出来ると思いますが >縦の列を転記終了後に次の項目の列のデータを転記させることは可能でしょか？ の意味がよくわかりません。 あと、データは追加されていくという事ですか？ （ｍｏｍｏ） ---- マトリックス状に入力してあるデータを 一行のデータにして転記する　って事ですよね？ 私なら、Workbooks("book1.xls").Sheets("Sheet1")のデータを どこかにスペースを設けて ("book2.xls").Sheets("Sheet2") のレイアウト の形に参照させておいて ("book2.xls").Sheets("Sheet2") へは、その行をコピペします。 すると、マクロにやらせなければ成らない作業 （許斐さんがマクロに「こうやってね」って言わなければ成らない事） が減ると思います。 (HANA) ---- momo　さん 説明不足ですみません ＞あと、データは追加されていくという事ですか？ はい300人ほどのデータを随時に追加していきます。 (許斐） ---- HANA さん 返信ありがとうございます。 >マトリックス状に入力してあるデータを >一行のデータにして転記する　って事ですよね？ はいそうです。 1.("book2.xls").Sheets("Sheet2") のレイアウト 氏名等の情報 + A服〜K服　日付1　日付2　日付3 + A-1服〜K-1服　日付1　日付2　日付3 + A-2服〜K-2服　日付1　日付2　日付3 横一列にデータを転記させます。 新データは最終行に追加する。　です。 2.("book3.xls").Sheets("Sheet3") のレイアウト 職員番号 + 氏名 + ふりがば + 1〜18を横一列 横一列にデータを転記させます。 新データは最終行に追加する。　です。 ＞私なら、Workbooks("book1.xls").Sheets("Sheet1")のデータを ＞どこかにスペースを設けて ＞("book2.xls").Sheets("Sheet2") のレイアウト ＞の形に参照させておいて ？？？参照でしょか？ 同じ形にデータを並べ替える？ていうことでしょか？ （許斐） ---- 小さなデータにして書きますが 例えば、Book2の並びが、10行目の様な並びなら [A] [B] [C] [D] [E] [F] [G] [1] 職員番号 1 [2] 氏名 山田花子 生年月日 2009/9/6 [3] 項目名 日付１ 項目名 日付１ [4] A服 H1.4.1 A-1服 H18.12.15 [5] B服 H1.4.1 B-1服 H1.4.1 [6] [7] [8] [9] [10] 職員番号 氏名 生年月日 A服 B服 A-1服 B-1服 [11] 1 山田花子 2009/9/6 H1.4.1 H1.4.1 H18.12.15 H1.4.1 [12] ↑=E1 ↑=B2 ↑=IF(B4="","",B4) [13] ↑=IF(B5="","",B5) 11行目の様に、それぞれのセルを参照して、その並びを作っておけば Book2には、11行目のデータを写すだけで良くなります。 マクロでの作業を考えたときの大きな流れとしては 　１．データ配置の変更 　２．転記先の確認 　３．転記 と言った指示を出すことになると思いますが 先に11行の様な行を数式で作っておけば １番目の作業をマクロで行う必要が無くなりますね。 (HANA) ---- HANA さん なるほどそういうことですね。 それも考えましたが、 このデータはまだいいんですが、150項目に増える場合は大変なことになりますね。 やはりせこせこと地道にやるしかないのですね（T0T) （許斐） ---- これだけ不規則な元データから並び替えるのでしたら、 ＶＢＡでコードを書いても数式でのリンクと同じかそれ以上に面倒ですよ。 面倒を避けるには集計しやすいように元の個人データを作成しておく事が大切だと思います。 私ならユーザーフォームで入力させて、いきなり集計リストにするか LAN環境だけで出来るのであれば、HTAなんかでブラウザから入力させてしまいます。 （ｍｏｍｏ） ---- 全部をマクロがやる様なコードを作るのと 一部数式も使用しながらコードをを作るのと 今まで通り手作業で転記するのと どれが早いか って事じゃないでしょうか。 コードだって「こんな風に動くコードよ、出来ろ！！」と 念じるだけでは出来ません。 自分がやることなら 決め打ちで　非常にテキトーなコードを作りますが。 地道にやるにしても 11行目の様なデータが有るか無いかは 作業に大きな差が出ると思います。 サンプルとして、エラー処理無しの決め打ちコードを載せておきます。 Sub 貸し出し() Dim mr As Long If ActiveWorkbook.Name = "Book2.xls" Or _ ActiveWorkbook.Name = "Book3.xls" Then MsgBox "ブックが違います。" Exit Sub End If With Workbooks("Book2.xls").Sheets("Sheet2") mr = .Range("A" & Rows.Count).End(xlUp).Row + 1 .Cells(mr, 1).Value = Sheets("Sheet1").Range("E1").Value '職員番号 .Cells(mr, 2).Value = Sheets("Sheet1").Range("B2").Value '氏名 .Cells(mr, 3).Value = Sheets("Sheet1").Range("E2").Value '生年月日 .Cells(mr, 4).Value = Sheets("Sheet1").Range("B4").Value 'A服 .Cells(mr, 5).Value = Sheets("Sheet1").Range("B5").Value 'B服 .Cells(mr, 6).Value = Sheets("Sheet1").Range("E4").Value 'A-1服 .Cells(mr, 7).Value = Sheets("Sheet1").Range("E5").Value 'B-1服 End With End Sub Sub サイズ() Dim mr As Long If ActiveWorkbook.Name = "Book2.xls" Or _ ActiveWorkbook.Name = "Book3.xls" Then MsgBox "ブックが違います。" Exit Sub End If With Workbooks("Book3.xls").Sheets("Sheet3") mr = .Range("A" & Rows.Count).End(xlUp).Row + 1 .Cells(mr, 1).Value = Sheets("Sheet1").Range("E1").Value '職員番号 .Cells(mr, 2).Value = Sheets("Sheet1").Range("B2").Value '氏名 .Cells(mr, 3).Value = Sheets("Sheet1").Range("E2").Value '生年月日 .Cells(mr, 4).Value = Sheets("Sheet1").Range("B11").Value '頭 .Cells(mr, 5).Value = Sheets("Sheet1").Range("B12").Value '首 .Cells(mr, 6).Value = Sheets("Sheet1").Range("B13").Value '胸囲 .Cells(mr, 7).Value = Sheets("Sheet1").Range("D11").Value '上衣丈 .Cells(mr, 8).Value = Sheets("Sheet1").Range("D12").Value 'ウエスト .Cells(mr, 9).Value = Sheets("Sheet1").Range("D13").Value '尻廻り End With End Sub Sub 両方() Call 貸し出し Call サイズ End Sub 以下の環境を整えて試して下さい。 Book1.xlsのSheet1 [A] [B] [C] [D] [E] [1] 職員番号 1 [2] 氏名 山田花子 生年月日 2009/9/6 [3] 項目名 日付１ 項目名 日付１ [4] A服 H1.4.1 A-1服 H18.12.15 [5] B服 H1.4.1 B-1服 H1.4.1 [6] [7] [8] [9] [10] サイズ [11] 頭 1 上衣丈 6 [12] 首 2 ウエスト 7 [13] 胸囲 3 尻廻り 8 Book2.xlsのSheet2 [A] [B] [C] [D] [E] [F] [G] [1] 職員番号 氏名 生年月日 A服 B服 A-1服 B-1服 [2] [3] Book3.xslのSheet3 [A] [B] [C] [D] [E] [F] [G] [H] [I] [1] 職員番号 氏名 生年月日 頭 首 胸囲 上衣丈 ウエスト 尻廻り [2] [3] ３つのブックを開き Book1をアクティブにした状態で実行します。 コードは、４つ目のブックを新規作成し そこへ置いておくのが良いかもしれません。 また、マクロでやらせるなら　転記日もどこかに書く様にしておくのが 良いのではないかと思います。 ループ処理などを入れるとコードも短くなるかもしれませんが 開発に時間も掛けられないなら この程度の物でも、一度作ってしまえば　無いよりは有る方がマシ？ この様な作りにするなら ＞150項目に増える場合は大変なことになりますね。 は、いずれにしても大変なのに代わりはないですね。 (HANA) ---- momo　さん フォームが複雑のため、マクロでは難しい　ですね。 いろいろ調べたところ、配列を定義するとできるかも、までは掴んだんですが、 いまいち何かが足りない。（たんなる考えが甘いだけかも、、、） 勉強不足ですね。 （許斐） ---- あ、衝突しちゃったけど　そのままのせとこ。 ループ処理などを入れると ってのも例えば .Cells(mr, 4).Value = Sheets("Sheet1").Range("B11").Value '頭 .Cells(mr, 5).Value = Sheets("Sheet1").Range("B12").Value '首 .Cells(mr, 6).Value = Sheets("Sheet1").Range("B13").Value '胸囲 .Cells(mr, 7).Value = Sheets("Sheet1").Range("D11").Value '上衣丈 .Cells(mr, 8).Value = Sheets("Sheet1").Range("D12").Value 'ウエスト .Cells(mr, 9).Value = Sheets("Sheet1").Range("D13").Value '尻廻り こんな所は　ここだけを取り出してテキトウに For i = 1 To 3 '頭,首,胸囲 .Cells(mr, i + 3).Value = Sheets("Sheet1").Range("B" & i + 10).Value Next For i = 1 To 3 '上衣丈,ウエスト,尻廻り .Cells(mr, i + 6).Value = Sheets("Sheet1").Range("D" & i + 10).Value Next なんて、事をするのもあり？ それにしても、左側が Cells で、右側が Range なんて。。。 (HANA) ---- HANA さん 返信ありがとうございます。光がまた一つ見えるように思います。 ＞ループ処理などを入れるとコードも短くなるかもしれませんが ＞開発に時間も掛けられないなら ＞この程度の物でも、一度作ってしまえば　無いよりは有る方がマシ？ 期限は今月中なので少し余裕があります。 サイズは何とかできそうですが、 服のほうが難しそうですね。 ループと配列のほうも少し調べてみます。 （許斐） ---- HANA　さん なんとなくこんな感じです。 ＞For i = 1 To 3 '頭,首,胸囲 >なんて、事をするのもあり？ 正常に動けばなんでもあり（笑 (許斐） ---- 配列でもRangeオブジェクトの直接参照でも処理的には大差ないです。 時間の差程度です。 氏名とかひらがななんかを見ると順番に並んでいないので、 面倒な事に変わりは無いですよね。 私が考えたコードもHANAさんのと殆ど同じコードでした。 ユーザーフォームが使えると、とても綺麗に簡単に作れますので 次のこのような作業の前までに勉強されてみると良いかもしれません。 （ｍｏｍｏ） ---- 何をどの様に処理することを考えておられるのかわかりませんが 一つのブックずつ処理をする（配置変換＆転記をする）事を 考えておられるなら　ｍｏｍｏさんも書いておられるように 配列を使っても　画期的に処理スピードが短くなることはないと思います。 また、ループ処理でコードを書いても 処理スピードがあがるわけではありません。 数式で配置換えを考えた時 ＞150項目に増える場合は大変なことになりますね。 という部分を重く見るのなら 配列の勉強よりも、ループ処理の勉強を なさった方が良いのではないかと思います。 また、私がのせたサンプルコードでは　セル番地が分かりやすいよう データ元のセルを Rangeを使用して書きました。 これを、Cellsの形に変更して書いてみると どこをどのようにループさせればよいのか 分かりやすくなるかもしれませんし 配列を使用したコードにする際も、考えやすくなると思います。 ＞期限は今月中なので少し余裕があります。 でしたら、まずは　Cells(行番号,列番号) 列はアルファベットではなく数で指定 する書き方で、コードを完成させてみるのが良いかもしれません。 服の方は、A列の処理（A服〜K服の処理）を考えた時 　　転記先もA服〜K服の順になっているなら 行方向へループさせるうちに列方向へのループを入れれば 良い事が分かると思います。 (HANA) ---- momoさん 返信ありがとうございます。 ユーザフォームはExcelに付属の メニュー → データ → フォーム でしたら、 一番に確かめましたが容量が多いためできませんでした。 (許斐) ---- HANAさん ありがとうございます。 まだ検証していませんが、これをもとに明日チャレンジしてみます。 (許斐) ---- >メニュー → データ → フォーム ではなくて、VBAのユーザーフォームです。 これを使えるようになれば、入力は単独で入力しやすいユーザーインターフェースを 用意する事ができて、さらにデータはリスト型式のデーターベースとして保存する。 という事が一連の作業の中でユーザーに意識させる事なく完成させられます。 （ｍｏｍｏ） ---- momo　さん >VBAのユーザーフォーム これははじめて知りました。アクセスに似ていますね。 これにすることにより VBAコードで設定しなくてOKになるんでしょか？ 登録は見つけましたが、 修正や検索などもできるのでしょか？ （許斐） ---- HANA さん 早速検証してみました。 ＞If ActiveWorkbook.Name = "Book2.xls" Or _ ＞ ActiveWorkbook.Name = "Book3.xls" Then ＞ MsgBox "ブックが違います。" ＞ Exit Sub 　これはシートを判別するものでしょか？ 　シートがあるかないかみたいな？？？ ＞With Workbooks("Book2.xls").Sheets("Sheet2") ＞mr = .Range("A" & Rows.Count).End(xlUp).Row + 1 ＞ .Cells(mr, 1).Value = Sheets("Sheet1").Range("E1").Value '職員番号 これはシート２A列の最終行を取得しE1の値を格納する。と分かりましたが、 ＞For i = 1 To 3 '頭,首,胸囲 ＞ .Cells(mr, i + 3).Value = Sheets("Sheet1").Range("B" & i + 10).Value 　　　　　　　3行を3列に格納 ^^^^^ 　　　　　　　　　ではこれなぜ10？？ ^^^^^^^ （許斐） ---- ＞これはシートを判別するものでしょか？ ＞シートがあるかないかみたいな？？？ シート名ではなく、ブック名を判定しています。 前提として Book1（データの有るブック）と Book2,Book3 が開いている状態です。 そして、コードは【アクティブブックの】Sheet1のデータを Book2とBook3にそれぞれ転記するコードです。 （データの有るブック名は　個人名がつけられている等 　固定でないと思ったので、ブック名を特定する処理ではなく 　【アクティブブック】と言う認識をさせています。 　ブック名が固定なら 　　　If ActiveWorkbook.Name <> "Book1.xls" Then とかで良いですね。） アクティブブックが、Book1で無い場合 つまり、データの有るブックとは違うブックだった場合 そのデータ（意図しないデータ）がBook2とBook3に転記されてしまいます。 それを避ける為に、事前にブック名を確認したいのですが 私は「データの有るブック名は固定ではない」と思っています。 データブックが一つ、転記先ブックが二つ開いている状態で アクティブブック名が、二つの転記先ブック名と違えば 消去法で、データブックがアクティブに成っていると考え その様なコードにしてあります。 ◆ ＞シート２A列の最終行を取得しE1の値を格納する。 なんだか、あれやらこれやらごっちゃに書いて居られます？ 変数mr に Book2のSheet2のA列の入力がある最終行の 行番号+1 を格納（メモ）し Book2のSheet2の mrの行で1列目のセルに 　アクティブブックのSheet1のE1セルの値を入れます。 まとめて書くと、書いて居られるような処理に成るかな？ （ちょっとイメージが違うんじゃないかと言う印象は受けますが。） ◆ ＞　　　　　　　3行を3列に格納 ^^^^^ 　　　　　　　　　ではこれなぜ10？？ ^^^^^^^ 今回使用している変数は、mr と i です。 Cellsはセル番地を表します。 Cells(行番号,列番号)の様に書き、例えば、C2セルは Cells(2 , 4) です。 ＞ .Cells(mr, 4).Value = Sheets("Sheet1").Range("B11").Value '頭 このコードは、変数mr が「2」だった場合 C2セルにSheet1のB11セルの値を書き込みます。 以下 ＞ .Cells(mr, 5).Value = Sheets("Sheet1").Range("B12").Value '首 ＞ .Cells(mr, 6).Value = Sheets("Sheet1").Range("B13").Value '胸囲 D2セルにSheet1のB12セルの値 E2セルにSheet1のB13セルの値 を書き込みます。 ＞ For i = 1 To 3 '頭,首,胸囲 ＞ .Cells(mr, i + 3).Value = Sheets("Sheet1").Range("B" & i + 10).Value ＞ Next このコードは、変数mr が「2」の時 ループ処理の一回目（i = 1）では 　　　.Cells(mr, １ + 3).Value = Sheets("Sheet1").Range("B" & １ + 10).Value 　　　　↓ 　　　.Cells(mr, 4).Value = Sheets("Sheet1").Range("B" & 11).Value 　　　　↓ 　　　.Cells(mr, 4).Value = Sheets("Sheet1").Range("B11").Value 　C2セルに、Sheet1のB11セルの値を書き込みます。 ループ処理の二回目（i = 2）では 　　　.Cells(mr, ２ + 3).Value = Sheets("Sheet1").Range("B" & ２ + 10).Value 　　　　↓ 　　　.Cells(mr, 5).Value = Sheets("Sheet1").Range("B" & 12).Value 　　　　↓ 　　　.Cells(mr, 5).Value = Sheets("Sheet1").Range("B12").Value 　D2セルに、Sheet1のB12セルの値を書き込みます。 ループ処理の三回目（i = 3）では 　　　.Cells(mr, ３ + 3).Value = Sheets("Sheet1").Range("B" & ３ + 10).Value 　　　　↓ 　　　.Cells(mr, 6).Value = Sheets("Sheet1").Range("B" & 13).Value 　　　　↓ 　　　.Cells(mr, 6).Value = Sheets("Sheet1").Range("B13").Value 　E2セルに、Sheet1のB13セルの値を書き込みます。 ◆ 因みに、最初にも書いていますように 「違うブックがアクティブになっていたら。。。」 程度は考えていますが 「Book2やBook3が開いて居なかったら？」や 「それぞれのシートがブックに存在しなかったら？」 なんてエラー処理は考えていません。 (HANA) ---- HANA　さん ありがとうございます。やっと理解できました。 ＞.Cells(mr, i + 3).Value = Sheets("Sheet1").").Range("B" & i + 10).Value　　　　　　　　　　　　　　　　　　　　　　　　　　 　^^^^^^^^^ は勘違いしていました。 Cells（行,列）と同じく ("B" & i + 10)もB列から+10列(K列）だと勘違いしていました（＾＾；；； （許斐） ---- HANA さん まだ一つですが、思い通りの結果得ることができました。 （といっても＾＾；；ほとんどHANAさんの書いたコードを使っただけですが。。。） Sub サイズ() Dim mr As Long Dim MaxRows As Long If ActiveWorkbook.Name <> "Book1.xls" Then Exit Sub End If With Workbooks("Book3.xls").Sheets("Sheet2") mr = .Range("A" & Rows.Count).End(xlUp).Row + 1 .Cells(mr, 1).Value = Sheets("Sheet1").Range("E4").Value '職員番号 .Cells(mr, 2).Value = Sheets("Sheet1").Range("B5").Value '氏名 .Cells(mr, 3).Value = Sheets("Sheet1").Range("B4").Value 'ふりがな For i = 1 To 5 '頭,首,胸囲 .Cells(mr, i + 3).Value = Sheets("Sheet1").Range("B" & i + 20).Value .Cells(mr, i + 8).Value = Sheets("Sheet1").Range("D" & i + 20).Value Next For i = 1 To 4 'ｷｬｯﾌﾟ,シャツ,上着,ズボン .Cells(mr, i + 13).Value = Sheets("Sheet1").Range("F" & i + 20).Value .Cells(mr, i + 17).Value = Sheets("Sheet1").Range("H" & i + 20).Value Next End With End Sub For i = 1 To 5 '頭,首,胸囲 　　　　　　^^^を最後の行を認識できたらもう少しコンパクトになりますね。 　　　　　　　　MAｘrowsで試したんですが、だめでした。違うのでしょか？？ （許斐） ---- まず、コードに関してですが。。。 変数i の宣言もしておいてあげてください。 それから、例えば For i = 1 To 5 '頭,首,胸囲 .Cells(mr, i + 3).Value = Sheets("Sheet1").Range("B" & i + 20).Value .Cells(mr, i + 8).Value = Sheets("Sheet1").Range("D" & i + 20).Value Next For i = 1 To 4 'ｷｬｯﾌﾟ,シャツ,上着,ズボン .Cells(mr, i + 13).Value = Sheets("Sheet1").Range("F" & i + 20).Value .Cells(mr, i + 17).Value = Sheets("Sheet1").Range("H" & i + 20).Value Next この部分は For i = 1 To 4 '頭,首,胸囲'ｷｬｯﾌﾟ,シャツ,上着,ズボン .Cells(mr, i + 3).Value = Sheets("Sheet1").Range("B" & i + 20).Value .Cells(mr, i + 8).Value = Sheets("Sheet1").Range("D" & i + 20).Value .Cells(mr, i + 13).Value = Sheets("Sheet1").Range("F" & i + 20).Value .Cells(mr, i + 17).Value = Sheets("Sheet1").Range("H" & i + 20).Value Next '↓'頭,首,胸囲の i=5 は一回なので個別に .Cells(mr, 8).Value = Sheets("Sheet1").Range("B25").Value .Cells(mr, 13).Value = Sheets("Sheet1").Range("D25").Value の様に i = 1 To 4 でまとめても良いかもですね？ あと、確認ですが ＞If ActiveWorkbook.Name <> "Book1.xls" Then として居られると言う事は、ブック名が固定ですか？ これは、一つのブックを使って　データを入力後転記。 同じブックのデータを削除して、次の人のデータを入力し転記。 と言う使用方法ですか？ （つまり、テンプレートの様な使用方法） それとも、それぞれの人に関して　同じ名前のブックが 複数存在するという事でしょうか？ さて、ご質問に関してですが。。。 ＞^^^を最後の行を認識できたらもう少しコンパクトになりますね。 これの意味がよく分かりません。 入力のある範囲は、事前に決まっているのかと思っていましたが？ それから、どの様に書けてコンパクトに成ると思われたのか イメージを教えていただければと思います。 (HANA) ---- HANA さん ＞これは、一つのブックを使って　データを入力後転記。 入力フォーム（bookは）一つだけです。 ＞入力のある範囲は、事前に決まっているのかと思っていましたが？ 今は決まっています。今後制服の種類が増えても対応できたらと思っただけです。 >イメージを教えていただければと思います。 If A列（項目名）<>　""　Then　 A列の項目名が空欄じゃないとき。B列の値を転記みないな？？？（なんとなくイメージです） 空欄の時はD列行って同じく処理するみたいな？ iの変数を追加しました。 （許斐） ---- ＞入力フォーム（bookは）一つだけです。 でしたら、マクロ実行ボタンをBook1のSheet1に置くことにして そこからしか実行しない状況にしておけば If ActiveWorkbook.Name <> "Book1.xls" Then の確認や、転記部分の .Cells(mr, i + 3).Value = Sheets("Sheet1").Range("B" & i + 20).Value ここにシート名を入れて限定していますが／~~~~~~~~~~~~~~~~~~ この部分も無くして仕舞っても良さそうですね。 ◆ ＞A列の項目名が空欄じゃないとき。B列の値を転記みないな？？？（なんとなくイメージです） 良く分かります。 そんなときは、For〜 でループさせるのではなく Do〜 でループさせる事が多いと思います。 ただ、その運用で本当に大丈夫でしょうか？ 今後制服の種類が増えた場合は、転記前に Book2やBook3の列も 移動させないといけないんですよね？ 移動させる前に気づかずにコードを実行してしまうと １行目の項目とは違う項目のデータが 気づかない内に各セルに入ることに成ると思いますが。。。 種類を増やした時にコードを変更するのを忘れて転記されないのと 転記先のブックの項目を変更するのを忘れて変な所へ転記されるのと。。。 キュウキョクノセンタク？ ＞入力フォーム（bookは）一つだけです。 って事なんで、転記後はマクロでデータを削除して仕舞えば 次に入力するときに 「あれ？データが残ってるんだけど。。。 　そうだ！！ここは項目を増やしたんだった！！」 と、コード他　変更する必要が有ることに気づけるかもしれません。 今回は、この程度に留めておくのが安全に思いますが。 (HANA) ---- HANA　さん そんなトラップが、、、分かりました。サイズはこのまま使用します。 貸し出しについてですが、 [A] [B] [C] [D] 項目名 日付1 日付2 日付3 [7] A服 1 12 23 [8] B服 2 13 24 [9] C服 3 14 25 [10] D服 4 15 26 [11] E服 5 16 27 [12] F服 6 17 28 [13] G服 7 18 29 [14] H服 8 19 30 [15] I服 9 20 31 [16] J服 10 21 32 [17] K服 11 22 33 ↓転記後表示したい結果 A服日付1 A服日付2 A服日付3 B服日付1 B服日付2 B服日付3 C服日付1 C服日付2 C服日付3 ・・・・・・・・・ 1 12 23 2 13 24 3 14 25 チャレンジしたループ（失敗に終わりました。） For ii = 1 To 3 ’日付1＆日付2＆日付3のつもり For i = ii To 11　'A服〜K服 .Cells(mr, i + 9).Value = Sheets("Sheet1").Range("B" & i + 6).Value .Cells(mr, i + 20).Value = Sheets("Sheet1").Range("F" & i + 6).Value Next Next どうしたら、表示させたい結果になるか教えてください。 （許斐） ---- 現在チャレンジして居られる事は、少し難しいです。 まず、右側を考えてみます。 例えば、B7:D7の転記を考えたとき ループの度に 　Sheet1のB7セル→Sheet1のC7セル→Sheet1のD7セル とやっていこうと思うなら これは列が移動しますので Sheets("Sheet1").Range("B" & i + 6).Value 　　　　　　　ここが／~~~~「B」で固定に成ってるのはおかしいですね。 こちらも、Cells(行,列)の形で書いてみられてはどうでしょう。 或いは、三つは続けて書く？ .Cells(mr, i + 9).Value = Sheets("Sheet1").Range("B" & i + 6).Value .Cells(mr, i + 10).Value = Sheets("Sheet1").Range("C" & i + 6).Value .Cells(mr, i + 11).Value = Sheets("Sheet1").Range("D" & i + 6).Value こんな感じで。 すると、行方向へのループだけで良いことに成りますね。 次に、左側を考えると。。。 今回は、今までみたいに単純に iに足し算するだけでは 列の数が合わないですね。 二重のループを考えるなら 一つセルを参照するたびに、書き出す列番号が一つ増えます。 三つ続けて書いた場合は、 　i が 1 の時は 1 i が 2 の時は 4 i が 3 の時は 7 って感じで増えていきますね。 一つループが終わるたびに +3 ずつ増える。 いずれにしても、左側の列をカウントする変数を 追加で用意するのが良さそうに思います。 まずは、右側を Cellsにしてループの中にループを入れるか それとも、Rangeのまま３行書いて、ループを一つでするか お好きな方を選んで、方針を決めて頂ければと思います。 (HANA) ---- HANA さん すみませんあまり理解しきれていないのですが、 ループは横の列か縦の列どちかにする、ていうことでしょか？ 参考するなにかありましたら、助かります。 （許斐） ---- えっと、 　どの様にでも書けるので 　先にそれを決めなきゃいけない って感じです。 どの様にループさせるかによって 書き出す列番号を決めていく方法が変わります。 A1から始まる簡単なサンプルコードを書いておきます。 [A] [B] [C] [D] [1] 項目名 日付1 日付2 日付3 [2] A服 1 12 23 [3] B服 2 13 24 [4] C服 3 14 25 [5] D服 4 15 26 [6] [7] [8] [9] A服 B服 C服 D服 [10] 日付1 日付2 日付3 日付1 日付2 日付3 日付1 日付2 日付3 日付1 日付2 日付3 [11] [12] まずは二重のループにして、書き出す列番号を一つずつ増やす。 Sub ふたつで() Dim i As Long, ii As Long, cn As Long For i = 1 To 4 'A服〜D服の4行分ループ For ii = 1 To 3 '日付1〜日付3の3列分ループ cn = cn + 1 Cells(11, cn).Value = Cells(i + 1, ii + 1).Value Next Next End Sub 　　i = 1 の時、ii = 1 〜 3 の処理が行われ、次に 　　i = 2 の時、ii = 1 〜 3 の処理が行われ・・・・ 　　って感じで進んでいきます。 ループは一つにして、書き出す列番号を+3 ずつふやす。 Sub ひとつで() Dim i As Long, cn As Long For i = 1 To 4 'A服〜D服の4行分ループ Cells(12, cn + 1).Value = Range("B" & i + 1).Value Cells(12, cn + 2).Value = Range("C" & i + 1).Value Cells(12, cn + 3).Value = Range("D" & i + 1).Value cn = cn + 3 Next End Sub 因みに、変数は　初期状態で 0　です。 (HANA) ---- HANA さん ありがとうございます。 ループについて理解しました。 早速試してみました。 二重フープは難しいですね。 やっとなんとなく理解できました。 質問です。 私の二番目のループは何が違うのでしょか@とAは転記してくれませんでした。 Sub 貸出入力() Dim mr As Long Dim i As Long, cn As Long If ActiveWorkbook.Name <> "Book1.xls" Then Exit Sub End If With Workbooks("Book2.xls").Sheets("Sheet1") mr = .Range("A" & Rows.Count).End(xlUp).Row + 1 .Cells(mr, 1).Value = Range("E4").Value '職員番号 .Cells(mr, 2).Value = Range("B5").Value '氏名 .Cells(mr, 3).Value = Range("B4").Value 'ふりがな .Cells(mr, 4).Value = Range("E5").Value '生年月日 .Cells(mr, 6).Value = Range("H5").Value '採用年月日 .Cells(mr, 8).Value = Range("H4").Value '階級 .Cells(mr, 9).Value = Range("J4").Value '所属 For i = 6 To 16 'A服〜D服の4行分ループ i = 0 For ii = 1 To 3 '日付1〜日付3の3列分ループ cn = cn + 1 .Cells(mr, cn + 9) = Cells(i + 1, ii + 1).Value .Cells(mr, cn + 45) = Cells(i + 1, ii + 5).Value .Cells(mr, cn + 81) = Cells(i + 1, ii + 9).Value Next Next For ii = 1 To 3 '日付1〜日付3の3列分ループ cn = cn + 1 　　　　　'@ .Cells(mr, cn + 42) = Cells(18, ii + 1).Value　 　　　　　'問題ありません .Cells(mr, 115).Value = Range("F18").Value '備考　 　　　　　'A .Cells(mr, cn + 112) = Cells(18, ii + 9).Value Next End With End Sub 　(許斐） ---- 思ったセルと違うセルを転記している （入力が無いセルで、転記されて居ない様に思える。） 思ったセルと違うセルへ転記している （違うセルを見ているので、転記されて居ない様に思える。） なんて事は無いですか？ '@の所は 　ii=1 の時　B18セルを BX列に ii=2 の時　C18セルを BY列に 　ii=3 の時　D18セルを BZ列に 転記しています。 下側の For ii = 1 To 3 '日付1〜日付3の3列分ループ の行にブレークポイントを設定して、 ステップインで実行しながら、cnの値がどうなっているのか 確認してみてください。 ブレークポイントは、コードの左側の灰色の部分をクリックすると 茶色い●が表示され、設定出来ます。 コードを実行すると、その場所で一端とまりますので [ F8 ]キーを押しながら一行ずつ実行させてください。 （黄色いハイライトの行が　一つずつ下がっていきます。） cnの値は、cnの上にマウスを持っていって少し待つと表示されます。 うまくいかない場合は、VBEメニューの表示(V)から ローカルウィンドウを表示させて、そちらで確認してみてください。 (HANA) ---- HANA　さん ありがとうございます。あまり理解はしていないのですが、 　@　.Cells(mr, cn + 9) = Cells(18, ii + 1).Value にしたところ↓思い通りの結果になりました。 ii=1 の時　B18セルを CA列に ii=2 の時　C18セルを CB列に 　ii=3 の時　D18セルを CC列に 一つ疑問ですが、 AFor i = 6 To 16 'A服〜D服の4行分ループ i = 0 For ii = 1 To 3 '日付1〜日付3の3列分ループ cn = cn + 1 .Cells(mr, cn + 9) = Cells(i + 1, ii + 1).Value cn+9が同じなのに問題ないのですねなぜ？ A の処理の後にまた9列目のにもだって@の処理をするのでしょか？ ダブらないのは不思議です。？？ (許斐）　　　　　　　　　　　　　 ---- 難しいですね。 cnの値がどのように移り変わっているのか分かりますか？ 前半部分も一行ずつ実行して確認していくと ＞cn+9が同じなのに問題ないのですねなぜ？ ＞A の処理の後にまた9列目のにもだって@の処理をするのでしょか？ ＞ダブらないのは不思議です。？？ この辺りの疑問も解けるかもしれません。 また、適当にやって数が合ったのならやはり ＞＞ステップインで実行しながら、cnの値がどうなっているのか ＞＞確認してみてください。 この様な作業で、自分で書いたコードが 実際にどの様に動いて居るのか また、その時の変数の値などを確認出来る様になると 思った通りに　疑問無く　動くコードを より短時間で作成出来るようになると思います。 (HANA) ---- HANA　さん 一度に処理されているわけではなく forで設定させた行数を処理終わるまで1行ずつ？行ったりきたりしていますね。 なるほどでです。 勘違いしていました。 本当にありがとうございます。お陰様で転記は無事に終わりました。 感謝　×100 (許斐） PS・ 指定された職員番号の行ごと削除はできましたが、 検索と内容修正はチャレンジしてみようと思います。 今作っているコードを逆にしたできるかな〜と思いましたが、甘いでしょか（汗 ---- ＞一度に処理されているわけではなく ＞forで設定させた行数を処理終わるまで1行ずつ？行ったりきたりしていますね そうです。 下側のループで、列がずれた理由も分かりましたか？ もう少し、転記部分のコードについて続けさせてください。 ＞変数i の宣言もしておいてあげてください。 と言う書き込みをした後に ＞それから、例えば ＞・・・（中略）・・・ ＞この部分は ＞・・・（中略）・・・ ＞の様に i = 1 To 4 でまとめても良いかもですね？ と書きました。 確かにすっきりするかもしれませんが、この様にしてしまうと 「この列は項目が一つ増えた」なんて時に修正が大変ですよね？ そういったことを考えると、前言を撤回して まとめない方が良い様に思います。 そして、順番に転記されて行くような コードにしておくのが良いかもしれません。 たとえば For i = 6 To 16 'A服〜D服の4行分ループ i = 0 For ii = 1 To 3 '日付1〜日付3の3列分ループ cn = cn + 1 .Cells(mr, cn + 9) = Cells(i + 1, ii + 1).Value .Cells(mr, cn + 45) = Cells(i + 1, ii + 5).Value .Cells(mr, cn + 81) = Cells(i + 1, ii + 9).Value Next Next この部分は　一度のループで 10,16,82列のセルにデータが入りますね。 もしも、項目が増えた場合　+45はいくつになれば良いの？　+81はいくつになれば良いの？ と、よく分かりません。 単調なコードになってしまいますが あとで修正する事を考えると 一つのまとまり毎に書いておいた方が 良さそうに思います。 データは、左から順に隙間無く埋まっていくと思いますので ループの中身は　.Cells(mr, cn + 9).Value = Cells(i , ii).Value で固定にして、i と ii の開始と終わりをまとまり毎に変更する。 ・・・・意味が分かりますか？ (HANA) ---- HANA さん ループ処理をまとめるではなく、 一回のブロックに一つのループを設定することにより 修正等あるとき一目で分かりやすいて言うことですね。 For i = 6 To 16 'A服〜D服の4行分ループ i = 0 For ii = 1 To 3 '日付1〜日付3の3列分ループ cn = cn + 1 .Cells(mr, cn + 9) = Cells(i + 1, ii + 1).Value .Cells(mr, cn + 45) = Cells(i + 1, ii + 5).Value .Cells(mr, cn + 81) = Cells(i + 1, ii + 9).Value Next Next ↑を　↓　 For i = 7 To 18 'A服〜D服の4行分ループ i = 1 For ii = 2 To 4 '日付1〜日付3の3列分ループ cn = cn + 1 .Cells(mr, cn + 9) = Cells(i, ii).Value Next Next For i = 7 To 17 'A服〜D服の4行分ループ i = 1 For ii = 6 To 8 '日付1〜日付3の3列分ループ cn = cn + 1 .Cells(mr, cn + 9) = Cells(i, ii).Value Next Next For i = 7 To 18 'A服〜D服の4行分ループ i = 1 For ii = 10 To 12 '日付1〜日付3の3列分ループ cn = cn + 1 .Cells(mr, cn + 9) = Cells(i, ii).Value Next Next にする？ （許斐） ---- そうです！！ （伝わって良かった。。。） そうしておくと、転記元のセル番地を見ながら i と ii に番号を写し取るだけで すむんじゃないかと思います。 どちらがより良いかは、許斐さんの判断にお任せします。 それから、今は　Cellsの中で cn+9 ってしてますね。 それは .Cells(mr, 9).Value = Range("J4").Value '所属 ここまでの間に 9列分はすでに入力済みだからですよね。 そこで、ループ処理を始める前に cn = 9 と 値を入れておけば　ループが始まった最初は cn = 9 + 1 = 10 ってなるので .Cells(mr, cn + 9) = Cells(i, ii).Value ここのところの +9 が／~~~~ それぞれ要らなくなると思います。 後は、このマクロはBook1のSheet1にマクロ実行ボタンを作って そこから実行するのでしょうから If ActiveWorkbook.Name <> "Book1.xls" Then Exit Sub End If も不要になりますよね？ それと、おまじない的な事になるかもしれませんが .Cells(mr, cn + 9).Value = Cells(i, ii).Value ~~~~~~~これもつけておかれるのが良いと思います。 細かい所だと、行方向のループのコメントが 全部「'A服〜D服の4行分ループ i = 1」ってなってますね。。。 項目名が何かの順になってないなら　列番号を入れるなど どの部分に関する処理をしているのか、分かるように 書いておかれるのが宜しいかと思います。 ちなみに ＞＞転記後はマクロでデータを削除して仕舞えば この部分は付け加えましたか？ (HANA) ---- HANA　さん ＞どちらがより良いかは、許斐さんの判断にお任せします。 言われたとおりに直しましたら列数を計算せずともわかるようになりました。 段落ごとのループを使用したいと思います。 ループはまとめ過ぎると後々が不憫になりますね。勉強になりました。 ＞下側のループで、列がずれた理由も分かりましたか？ シートの列番号をそのまま入れたからです。 >ここまでの間に 9列分はすでに入力済みだからですよね。 はい。それは分かりました。 変数ii忘れてました＾＾；； >ループ処理を始める前に cn = 9 cn = 9 For i = 7 To 18 'A服〜D服の4行分ループ i = 1 For ii = 2 To 4 '日付1〜日付3の3列分ループ cn = cn + 1 .Cells(mr, cn).Value = Cells(i, ii).Value 省略-------------------------------- .Cells(mr, 115).Value = Range("F18").Value '備考 End With ↑こんな感じですか？ 　＞＞転記後はマクロでデータを削除して仕舞えば 転記してから値をクリアさせると親切ですね え〜とちょっと横のループにチャレンジ（あまり必要性がないかも＾＾；；） （許斐） ---- ＞ループはまとめ過ぎると後々が不憫になりますね。 そうですね。 まとめかたにもよると思いますが。。。 まとめれば良いってものでも無いと思いますので。 状況にもよりますよね。タブン。 ＞シートの列番号をそのまま入れたからです。 あ、そうだったんですか。 ループが終わると cnがリセットされる様な 印象をもっておられたのかと思いましたが。。 ＞こんな感じですか？ そんな感じです。 ＞転記してから値をクリアさせると親切ですね というか、まぁ親切ですが　あのときも書いた様に 「うっかりコードを変更してなくて 　転記されなかった時に気づくように」 って意味もあります。 たとえそれを入れていても 削除する方だけなおして　実際に転記する部分を直さない なんて中途半端になおしたのでは 何の足しにもならないのですが。 ＞ちょっと横のループにチャレンジ はい、チャレンジしてください。 ただし、実際は　セルをまとめて指定して 削除する事にした方が良いんじゃないかと思います。 セルへの処理は時間がかかりますので。 たとえば、 Range("B4:B5,E4:E5,H4:H5,J4").ClearContents で、該当の7セルの内容を削除出来ます。 あ、今気づきましたが 「貸し出し」の転記と「サイズ」の転記を 別コードにするなら　共通部分のデータを どの段階で消せば良いのかは 考えないといけないですね。 どちらも同時に実行すれば良いのかな？ でしたら、全部済んだ後に 消せば良さそうですが。 (HANA) ---- HANA さん すごく簡単なの作ってみました。 クリアはこれしか知らない私である。（涙；； Sub 値のみクリア() '氏名等 Range("B5,B4,E5,E4,H5,H4,J4,F18").Select Selection.ClearContents '貸し出し Range("B7:D18,F7:H18,J7:L18").Select Selection.ClearContents 'サイズ Range("B21:B25,D21:D25,F21:F24,H21:H24").Select Selection.ClearContents End Sub あれ？↓短縮できたんですね＾＾;; Sub 値をクリア() '氏名等 Range("B5,B4,E5,E4,H5,H4,J4,F18").ClearContents '貸し出し Range("B7:D18,F7:H18,J7:L18").ClearContents 'サイズ Range("B21:B25,D21:D25,F21:F24,H21:H24").ClearContents End Sub ＞「うっかりコードを変更してなくて転記されなかった時に気づくように」 で思い出しました。職員番号ダブりをなくしたいです。 転記する前にチェックさせることできますか？ （許斐） ---- ＞クリアはこれしか知らない いや、それしかないかと。。。 ＞あれ？↓短縮できたんですね マクロの記録で得られるコードは 　△△.Select　　Selection.×× となりますが、コードを書く際は Selectしないコードを心がけるのが良いと思います。 マクロの記録をご活用でしたら 　△△.Select　　Selection.×× をみたら、 △△.×× の形になおしてみるのが良いと思います。 ＞転記する前にチェックさせることできますか？ COUNTIF関数で調べましょう。 ＞検索と内容修正はチャレンジしてみようと思います。 を見据えるなら、MATCH関数の方が良いかな？ ＞指定された職員番号の行ごと削除はできましたが これはどのようにやったのでしょう？ (HANA) ---- HANA さん ＞マクロの記録をご活用でしたら そうなんですか？なるほどそのようにします。 ＞MATCH関数 　そうなんですか？？VBAの関数？普通の関数？ ＞検索と内容修正はチャレンジしてみようと思います。 1/4はものまねで、無駄が多いですがこんな感じです。 Public Sub 削除_Click() Dim kt Dim k Dim wb(1 To 2) As Worksheet Dim WS Dim i As Long Dim res As Long k = Workbooks("book1.xls").Worksheets("sheet1").Range("B5").Value kt = Workbooks("book1.xls").Worksheets("sheet1").Range("E4").Value Set wkSheets(1) = Workbooks("book2.xls").Worksheets("sheet1") Set wkSheets(2) = Workbooks("book3.xls").Worksheets("sheet2") res = MsgBox(k & "のデータを削除しますか？ ", vbYesNoCancel) If res = vbCancel Then Cancel = True MsgBox "キャンセルします。" Else For Each WS In wb With WS For i = .Cells(WS.Rows.Count, 1).End(xlUp).Row To 1 Step -1 If .Cells(i, 1).Value = kt Then .Rows(i).Delete End If Next End With Next MsgBox "削除しました。" End If End Sub （許斐） ---- 一つずつ見ていく方式ですね。 でしたら、ループが全部終わっても If .Cells(i, 1).Value = kt Then の次の行へ行かなかったら、データが無かった事が分かりますね。 Then 〜 End If の間に 今は Rows(i).Delete をしていますが たとえば 　fr = i とかで セルの値が一致したら、その行を fr って変数に入れて Next が終わった時に fr が 0のままなら　入力は無かった。 0以外だったら、入力があって、何行目か？と言うと fr行目。 ＞VBAの関数？普通の関数？ 普通の関数が一部、VBAでも使えます。 番号の有無を調べるだけなら Sub 有無チェック() Dim kk, ws As Worksheet Set ws = Workbooks("book2.xls").Worksheets("sheet1") kk = Application.CountIf(ws.Range("A:A"), Range("B5").Value) If kk > 0 Then MsgBox "ありました。" Else MsgBox "ありません。" End If Set ws = Nothing End Sub こんな感じで Matchを使うとこんな感じ。 Sub どこにあるか() Dim kk, ws As Worksheet Set ws = Workbooks("book2.xls").Worksheets("sheet1") kk = Application.Match(Range("B5").Value, ws.Range("A:A"), 0) If IsNumeric(kk) Then MsgBox kk & "行目にありました。" Else MsgBox "ありません。" End If Set ws = Nothing End Sub 番号が重複していた場合 kkに入るのは、上側の行数になります。 (HANA) ---- HANA さん 私結構HANA さんの問いかけ見逃していますね(- -) >全部「'A服〜D服の4行分ループ i = 1」ってなってますね。。。 すごいコピペしたのでぜんぜん気付きませんでした^ ^;;;;;直して置きます。 >「貸し出し」の転記と「サイズ」の転記を別コードにするなら　共通部分のデータをどの段階で消せば良いのかは考えないといけないですね。 二つを一つにするんですか？できそうですね。 end withの後にサイズのwith〜入れる？かんじですね。 (許斐) ---- 私も返信忘れてました。。。 ＞＞マクロの記録をご活用でしたら ＞そうなんですか？なるほどそのようにします。 ただ、そう単純に行かない事も有りますので 変更後はよ〜く確認して下さいね。 ◆ ＞二つを一つにするんですか？ いや、一寸意味が違うと思います。。。。 Sub 貸出入力() Sub サイズ() と、それぞれ単独で動かせる作りにして有りますよね？ これを、 　１．ある時は「貸出入力」だけ実行 　２．ある時は「サイズ」だけ実行 　３．ある時は　両方　実行 と言う使い方にすると・・・・ ３をした時は全てのデータを消せば良いですが １の時は後で２をする可能性を考えると 共通部部分のデータは消せませんよね。 また、２の時も　後で１をする可能性があるなら やはり共通部分のデータは消せません。 「別々にしてあるけど、必ず一連で作業をする」 と言う事なら、転記作業が終わった後で今作ってある 　Public Sub 削除_Click() で、全部のデータを消してしまえば良さそうに思いますが。。。 貸し出しのデータは　例えば前年のデータが有っても使えませんが サイズなら、前年のデータが有るなら　それをわざわざ 書き直す必要は無いんじゃないかと。。。 となると、その場合はやはり　１のパターンで実行する事になる？ とか言う事なんですが。。。どの様にお考えでしょう？ ・・・まぁ、ウエストとかは　変わっちゃう人も居られそうなので あまり考えずに全て更新して仕舞う事にしておくのが安全かな？ (HANA) ---- HANA さん フム。。。 使う方々は年配の方が多いため作業単純にしたいと思っています。 このデータ処理の流れは ○新規登録ボタン 転記するのは新入社員のデータのみ(実行はいつも3番のみ) ○検索ボタン データをみるため(実行は3番のみ) ○修正ボタン 内容を修正する(実行は3番のみ) 作業着のため駄目になり易いのです。 そのためサイズより貸出日付がコロコロ変わるんです。 ○削除ボタン 退職者データを削除(実行は3番のみ) ↑これが設定処理です。 (許斐) ---- あらら、私は 許斐さんか、有る程度エクセルが分かる方が 既に出来ている表をリスト形式にまとめるために 「コードで簡単に出来ないかなぁ」 って事かと思っていたのですが ＞使う方々は年配の方が多いため って事ですか。。。 もしかして、ブックを三つに分けているのも 　データブックはサーバーに置いて 　入力ブックは各端末に置いて なんて事を考えて居られるのですか？ (HANA) ---- HANA さん ＞「コードで簡単に出来ないかなぁ」 　2年前まではエクセルのフォームでで約200人分作って管理したようです。 　すぐに検索できないかと言われ 　マクロに変えようと考えました。 ＞もしかして、ブックを三つに分けているのも〜 　サーバにデータ三つあります。 　三つに分けているのは統一にしたいからです。（癖を付けたい(笑））　 　担当者以外はフォームの検索はいいけどデータは触らないみたいな〜。 　 こんな感じにしてみました。 後は @を追加し Aメッセージに”○○シートの○○行目に重複職員番号があります。” なんてできたら超完璧なものに仕上がります。（☆▽☆） Sub 貸出入力() Dim mr As Long Dim i As Long, ii As Long, cn As Long Dim kk, ws As Worksheet '職員NO存在チェック Set ws = Workbooks("book2.xls").Worksheets("sheet1") @ Set ws = Workbooks("book3.xls").Worksheets("sheet2") kk = Application.Match(Range("E4").Value, ws.Range("A:A"), 0) If IsNumeric(kk) Then A MsgBox kk & "行目に職員番号重複ありました。" Else '服 With Workbooks("book2.xls").Sheets("Sheet1") （許斐） ---- ＞三つに分けているのは統一にしたいからです。（癖を付けたい(笑）） 済みません、よく分かりません。 何を統一したいのでしょう？ また ＞使う方々は年配の方が多いため と言う状態で 「入力するときは、後二つ　別のブックを開いておかないといけないよ」 ってのを徹底させるのには不安を感じますが。 (HANA) ---- >「入力するときは、後二つ　別のブックを開いておかないといけないよ」 ・データの呼び出しの時も開く必要あるんですか？ ・ファイル開かなくても処理できないのでしょか？ ・シートを一つにすると重くはありませんか？(約200×115×2枚） （許斐） ---- 私はこれまで 開いていることが前提のコードを書いています。 ＞シートを一つにすると重くはありませんか？ 仮にデータを入れてやってみられては？ (HANA) ---- ひとつのbookにしました。 ちょと重いけどいちいち開くより・・・・。 （許斐） ---- ＞ちょっと重い ってのは、開くのに時間がかかりますか？ そのブックにはデータしか入っていないですか？ A1:DK200の範囲に「1/1」と入れたシートを 二枚作成して試しましたが こちらではスムーズに開く様に思います。 たとえば、ブックを別々にして 三つ開く事を考えると　それでも 別々になっている方が動きが早いのですか？ それとは別で。。。再度確認させてください。 複数の人が同時にブックを開いて使用する様な 運用を考えておられますか？ (HANA) ---- HANA さん >こちらではスムーズに開く様に思います。 私のPCも平気です。。。。 担当に2択させたところ一つのbookを使うそうです（−。−） >複数の人が同時にブックを開いて使用する様な〜 複数の人を使用しますが、複数の人が同時に開くことはあまりないと思います。 bookをーつにしたところエラーが発生しました。 「インデェックスが有効な範囲にありません」 なぜでしょか？？ Set ws = Worksheets("貸出") （許斐） ---- ＞Set ws = Worksheets("貸出") でそのエラーが出たのなら アクティブになっているブックに 「貸出」と言うシート名のシートが 無い事が考えられます。 前後にスペース等要らない文字が入っていないか。 等、確認してください。 「貸出」シートはちゃんとある！！ って事なら、問題のあるコードを 全部載せてもらうのが良いかもしれません。 また、Set するのではなく With を使って書いても良いかもしれません。 　Set すると　何をSetしたのか 　覚えておかないといけないので。。。 (HANA) ---- HANAさん ありがとうございます。お陰様で思い通りになりました。 登録はこれで完成です。（☆○☆）感激〜♪ またくると思いますので。その時もよろしくお願いします。 ＞前後にスペース等要らない文字が入っていないか。 間に半スペースが。。。 直したところ思い通りになりました。 (許斐） ---- 出来ましたか、良かったです。 ＞職員NO存在チェック は、E4セルに番号が入力された段階で 行うのが良いのではないかと思います。 そして、その際 重複があったらそのデータを各セルに呼び出す。 　登録と逆をやれば大丈夫だと思います。 重複が無かったら、各セルのデータをクリア。 　ただし、E4セルには　入力したデータが 　残っていないといけませんが。 って感じで出来ると良さそうですね。 ＞またくると思いますので。 って事ですが せっかくなので、Public Sub 削除_Click() に関しても話を続けさせてもらえると 良いと思うのですが。 (HANA) ---- HANA さん ありがとうございます。今検索をチャレンジ中です。 ＞に関しても話を続けさせてもらえると とってもありがたいです。なんとなくこんな感じかな？？としか。。。 よろしくお願いします。 For Each WS In wb With WS For i = .Cells(WS.Rows.Count, 1).End(xlUp).Row To 1 Step -1 'A列 最終データの一行上 If .Cells(i, 1).Value = kt Then '検索値と等しかったら .Rows(i).Delete 'この行を削除 End If Next End With (許斐） ---- そうなんです！！ 行削除は下からループが基本なんです。 たとえば↓の様な表で [A] [1] HANA [2] HANA [3] 許斐 [4] 許斐 [5] HANA [6] HANA [7] 許斐 [8] 許斐 HANAの行を消そうと思って、上からループの Sub 削除1() Dim i As Long, kt As String kt = "HANA" For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row If Cells(i, 1).Value = kt Then Rows(i).Delete End If Next End Sub をすると、上手く行きそうで　実際は上手く行きません。 なぜだか分かりますか？ ステップインで実行しながら 考えてみてもらえると良いのですが。 ・・・って思いましたがもしかして ＞'A列 最終データの一行上 って事は、下からループしておられる自覚が無い？？ 一応、削除1 の下からループバージョンは Sub 削除2() Dim i As Long, kt As String kt = "HANA" For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1 If Cells(i, 1).Value = kt Then Rows(i).Delete End If Next End Sub と言う事になりますが。。。。 それぞれ、iの値の変化の仕方にも注意して観察してみてください。 (HANA) 　 ---- HANA　さん ＞For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1 　最終行の一行上より処理開始は分かりました。 　なぜ上から下からなのか分かりませんでした。 　実行したところ 　上からだと上の一行しか削除されず 　下からだと全部削除してくれますね。（？？） （許斐） ---- えっと・・・ ＞For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1 は「最終行の一行上より処理開始」では【無い】ですが 最終行の一行上より処理開始【では無い事】が分かりました？？ i = 最終行 から 1　まで iの値を一つずつ減らしながら（=Step -1)　のループです。 だから、下から上と表現しました。 　8行目のデータを確認して　削除するか・しないか 　7行目のデータを確認して　削除するか・しないか 　　： 　1行目のデータを確認して　削除するか・しないか 一方、削除1の方は i = 1 から 最終行　まで iの値を一つずつ増やしながら　実行されて行きます。 　1行目のデータを確認して　削除するか・しないか 　2行目のデータを確認して　削除するか・しないか 　　： 　8行目のデータを確認して　削除するか・しないか ステップインで実行すると、iの値が 片方（削除2）は減っていって、片方（削除1）は増えていきますよね？ ＞（？？） エクセルになったつもりで上からループ（削除1） をワークシート上で実行してみてください。 まず、 　i = 1 の時 A1セルの値を確認して1行目を削除します。 　　　すると、2行目が1行目にあがってきます。 （A2セルがA1セルの位置に来る。） 　i = 2 の時 A2セルの値を確認します。。。。 A2セルの値は「許斐」ってなってますね。 意図した動きとしては 「HANA」を確認してその行は削除 なのですが。。。 (HANA) ---- HANAさん つまりこういうことですか？削除1の場合 　　　　　[A] [1] HANA　　　←削除 [2] HANA [3] 許斐 実行結果 [A] [1] HANA　←2番目のHANAが[1]行目にUPし、マクロは次行を処理するためですね。 [2] 許斐 削除2の場合 　　　　[A] [1] HANA [2] HANA [3] 許斐 [4] 許斐 [5] HANA [6] HANA　　←　削除 実行結果 　　　　[A] [1] HANA [2] HANA [3] 許斐 [4] 許斐 [5] HANA [6]　　　6行目削除して行がUPしないので、次行行って処理しても支所がないため上手く実行できる。 てことですね＾＾ （許斐） ---- はい。 どの様な事に成ったのかは関係なく iの値は一つ増えますからね。 さて、今回の場合は　どうでしょう。 「重複入力されない」が前提であれば 下からループする必要は無いと思います。 まぁ、下からループしても 問題は無いのですが。 (HANA) ---- ありがとうございます。削除1で大丈夫ですね^ ^ すごく分かり易い解説をありがとうございます。 いま迄なんと無く理解したものが明確になった感じです。 (許斐) ---- 上からループ・下からループが 分かって頂けた様ですので　もう一つ。 例えば、こんなデータを想定します。 [A] [1] 許斐 [2] 許斐 [3] HANA [4] 許斐 [5] 許斐 [6] 許斐 [7] 許斐 [8] 許斐 今回も「HANA」の行を消すのですが このデータは実際のデータにより近い 「重複入力されない」が前提として有るデータです。 削除1を実行すると（削除2でも同じですが） 確かに 3 行目が削除されて希望する結果が得られます。 でも、ご自身でやるときの事を考えてみてください。 一致するデータが一つしかないのですから 一つ一致した段階で、それ以降は確認しませんね？ 　１行目を見比べて　違うので　次の行へ 　２行目を見比べて　違うので　次の行へ 　３行目を見比べて　同じなので　行削除したら 　次の行へは行かず、見比べる処理を終了。 現在のコードでは、Cells(Rows.Count, 1).End(xlUp).Row まで、ループ処理が繰り返されます。 もしもデータが200行まで有って、3行目に「HANA」が有っても 残り 4〜200 のループは繰り返され 「見比べる」行為が実行されます。 途中でもループ処理を終わって良い状態になれば その段階で Exit For しましょう。 Sub 削除3() Dim i As Long, kt As String kt = "HANA" For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row If Cells(i, 1).Value = kt Then Rows(i).Delete Exit For End If Next End Sub 今回の場合は、一致するデータが見つかって行を削除したら ループ処理は終了すれば良いですね。 これまでの二つと、最終的には同じ結果に成りますが [ F8 ] を押す回数は変わると思います。 　　コードは一行増えましたけど。 これも又、ステップインで実行しながら 違いを確認して頂ければと思います。 (HANA) ---- そか^ ^そこまで気づかなかったです。 無駄なループがなくなりますね。 これはすごくいいですね。いろいろ使えそう。 Exit ForはForを使わなくても使えますか？ 処理を中止ですからつかえそうなきも。。。 あ!今のループで思い出しました。 新規登録時の絶対条件 @名前と職員番号 空欄は登録させないようにしない後が大変ですね。 p.s 月曜に検索と修正のレスして頂けますか？ HANAさんのレスは非常分かり易く勉強になります。 許斐 ---- ＞Exit ForはForを使わなくても使えますか？ 微妙な発言ですね。（笑） 途中でマクロを終了なら、Exit Sub ですが そう言うこと？ ＞ @名前と職員番号 ＞空欄は登録させないようにしない後が大変ですね。 本当ですね！！ 確認する様にして下さい。 　両方データが有るときに　Call ×３ ってな感じで。 後は、実行速度の問題ですが 登録・削除共にどうでしょう？ 気になる程はかからないんじゃないかと思いますが。 忘れない内にお伺いしておきたい事が有ります。 貸出データはリセットされる様な事は無いのですか？ 例えば「一年毎」とか。。。。 ちなみに、現在完成している （完成しましたよね？ 　・・・「空欄は登録させない」は追加が必要なのか。） 登録と削除のコードを再度載せてみてもらいたいのですが。 （上記追加後の物を。） そうそうp.s返し 　有難う御座います。 　可能な限りレスさせて頂きます。 　　他のみなさんも親切な方ばかりですから心配無いと思います。 　その際は新たに質問を立ててもらえると嬉しく思います。 　　このスレも、かなり長くなって仕舞いましたので。 　ただ、こちらが終わるまではしばらくまって頂ければと思います。 　 (HANA) ---- >途中でマクロを終了なら、Exit Sub ですが そうなんですか。 forがあるので for i=1 to 3みたいのが必要かと思いました^ ^;;;; データはリセットしないです。上書き方式です。 実行速度は一瞬です。^ ^d コードをのせるのは月曜にさせて下さい。 本日は外にいるためケイタイで返事のみ。(. .") レスも終わったと思いましたがまだまだおぼえる事が多いですね。 終了ご新しい質問を立ち上げます。 許斐 ---- ＞for i=1 to 3みたいのが必要かと思いました^ ^;;;; えっと、よく分からないのですが。。。 For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row Exit For Next こう言ったことですか？ For i〜（iのループ）から Exit します。 たとえば For i = 1 to 3 For ii = 1 to 3 Exit For Next Next だと、iiのループからExit します。 このコードだと、ii =1 の時が実行されたら すぐに Exit For するのでiiのループは 無いも同然の結果になりますね。 Next と Next の間に一行入れて書くと i のループからExitです。 (HANA) ---- HANA さん 理解しました。 Exitはそとにでる For i = 1 to 3のループでる場合は Exit Forで Subのループをでるときは Exit Subにすればオッケですね＾＾ ＞登録と削除のコードを再度載せてみてもらいたいのですが。 Sub 登録() Dim mr As Long Dim i As Long, ii As Long, cn As Long Dim kk, WS As Worksheet Dim msg As String Set WS = Worksheets("貸出") kk = Application.Match(Range("E4").Value, WS.Range("A:A"), 0) '職員番号と氏名チェック If Range("B5").Value = "" Then msg = vbLf & "氏名を入力してください。" End If If Range("E4").Value = "" Then msg = msg & vbLf & "職員番号を入力してください。" End If If Len(msg) Then MsgBox msg Exit Sub End If '職員NO存在チェック If IsNumeric(kk) Then MsgBox kk & "行目に重複の職員番号がありました。" Else '↓ダブりがないときの処理 '服 With Sheets("貸出") mr = .Range("A" & Rows.Count).End(xlUp).Row + 1 .Cells(mr, 1).Value = Range("E4").Value '職員番号 .Cells(mr, 2).Value = Range("B5").Value '氏名 .Cells(mr, 3).Value = Range("B4").Value 'ふりがな .Cells(mr, 4).Value = Range("E5").Value '生年月日 .Cells(mr, 6).Value = Range("H5").Value '採用年月日 .Cells(mr, 8).Value = Range("H4").Value '階級 .Cells(mr, 9).Value = Range("J4").Value '所属 cn = 9 '9行目〜の設定 For i = 7 To 18 '行番頭 i = 1 For ii = 2 To 4 '列番号 cn = cn + 1 .Cells(mr, cn).Value = Cells(i, ii).Value Next Next For i = 7 To 17 '行番号 i = 1 For ii = 6 To 8 '列番号 cn = cn + 1 .Cells(mr, cn).Value = Cells(i, ii).Value Next Next For i = 7 To 18 '行番号 i = 1 For ii = 10 To 12 '列番号 cn = cn + 1 .Cells(mr, cn).Value = Cells(i, ii).Value Next Next .Cells(mr, 115).Value = Range("F18").Value '備考 End With 'サイズ With Sheets("サイズ") mr = .Range("A" & Rows.Count).End(xlUp).Row + 1 .Cells(mr, 1).Value = Range("E4").Value '職員番号 .Cells(mr, 2).Value = Range("B5").Value '氏名 .Cells(mr, 3).Value = Range("B4").Value 'ふりがな For i = 1 To 5 '頭,首,胸囲 .Cells(mr, i + 3).Value = Range("B" & i + 20).Value .Cells(mr, i + 8).Value = Range("D" & i + 20).Value Next For i = 1 To 4 'ｷｬｯﾌﾟ,シャツ,上着,ズボン .Cells(mr, i + 13).Value = Range("F" & i+20).Value .Cells(mr, i + 17).Value = Range("H" & i+20).Value Next End With End If End Sub −−−−−−−−−−−−−−−−−−−−−−−−− Sub 値をクリア() '氏名等 Range("B4:C5,E4:F5,H4:H5,H4:H5,J4").ClearContents '貸し出し Range("B7:D18,F7:H18,J7:L18").ClearContents 'サイズ Range("B21:B25,D21:D25,F21:F24,H21:H24").ClearContents End Sub −−−−−−−−−−−−−−−−−−−−−−−−− Sub 行削除() Dim kt Dim k Dim wb(1 To 2) As Worksheet '異なるBookの（このばあい）2つのシートを参照します Dim WS 'WS はVariant型に変更します Dim i As Long Dim res As Long k = Worksheets("フォーム").Range("B5").Value kt = Worksheets("フォーム").Range("E4").Value Set wb(1) = Worksheets("貸出") Set wb(2) = Worksheets("サイズ") res = MsgBox(k & "のデータを削除しますか？ ", vbYesNoCancel) If res = vbCancel Then Cancel = True MsgBox "キャンセルします。" Else For Each WS In wb With WS For i = .Cells(WS.Rows.Count, 1).End(xlUp).Row 'A列 最終データ行より上にループして、 If .Cells(i, 1).Value = kt Then 'セルの値が 検索値と等しかったら .Rows(i).Delete 'この行を削除 Exit For End If Next End With Next MsgBox "削除しました。" End If End Sub ---- Sub 登録() のコードに関してですが Set WS = Worksheets("貸出") kk = Application.Match(Range("E4").Value, WS.Range("A:A"), 0) この２行は、「職員NO存在チェック」の為のものですから このコメントの下で処理をされるのが良いのではないかと思います。 また、ここではせっかく Setしてあるのですが WSは一度しか使われていません。 それなら、直接書いても良さそうな気もします。 kk = Application.Match(Range("E4").Value, Worksheets("貸出").Range("A:A"), 0) 検索と修正のコードを作成する際に こちらのコードも変更する事になるかもしれませんので （修正時の登録って、新規登録とほとんど同じだと思うので。） この辺りで一度仕切らせていただければと思います。 (HANA) ---- HANA　さん ＞kk = Application.Match(Range("E4").Value, Worksheets("貸出").Range("A:A"), 0) に変更しました。 ＞この辺りで一度仕切らせていただければと思います。 このレス終了ていうことですね。 親切に分かりやすいレスをありがとうございます。 お陰様でマクロの勉強が少し楽しくなりました。次のステップもがんばりますp(^^)q （許斐）