エクセルのデータ加工

質問

過去ログなどを探してみましたが見つけられませんでしたので
ご教示下さい。
ワードで差込印刷を行うために、以下のシート１をシート２へ
加工したいのですが・・・・レコードが５０００位です。
（シート１）
Ａ　Ｂ　Ｃ　Ｄ
１　ａ　あ　男
１　ｂ　い　女
２　ｃ　う　男
３　ｄ　あ　女
３　ｅ　う　女
３　ｆ　あ　女

（シート２）
Ａ　Ｂ　Ｃ　Ｄ　Ｅ　Ｆ　Ｇ　Ｈ　Ｉ　Ｊ　Ｋ　Ｌ　Ｍ
１　ａ　あ　男　ｂ　い　女
２　ｃ　う　男
３　ｄ　あ　女　ｅ　う　女　ｆ　あ　女

こんな加工を一括して行えますでしょうか？
事業所番号Ａにて管理を行っています。
現在シート１なのですが差込印刷を事業所ごとに行う必要があります。
そのためシート２のように加工したいのですが・・・
宜しくお願いいたします。

回答No.4

ham_kamo · ベストアンサー

No.2です。うまくマクロが動いてよかったです。
簡単ですが解説をさせていただきます。

For Each R In WS1.Range("A1", WS1.Range("A65536").End(xlUp))
　：
　：
Next

という文で、Rという変数が Sheet1 のA1からA列の最後のデータまでループでまわるようにしています。
このRというセルの値が Sheet2 のA列に存在するかを、

Set SearchRec = WS2.Range("A:A").Find(R.Value)　…(1)

で調べています。それで、はじめて出てきた場合は、

R.Resize(1, 4).Copy WS2.Cells(EndRow, 1)　…(2)

を実行しています。R.Resize(1, 4)というのは、
「Rの領域を1行4列に変更（拡大または縮小）する」
という意味で、たとえばRが A10 を差していたとき、R.Resize(1, 4)は A10:D10 という領域を意味します。その領域を、Sheet2 の最終行の１列目にコピーする（つまりA～D列にコピーされる）というのが(2)の行です。

はじめて出てきた数字ではないとき、(1)の命令によって Sheet2 のA列の中でRと同じ数が入っているセルが SearchRec という変数に入ります。今度はRの右３列を、SearchRec の行の右端にコピーする必要があります。そこで実行されるのが以下の行です。

R.Offset(0, 1).Resize(1, 3).Copy SearchRec.End(xlToRight).Offset(0, 1)　…(3)

R.Offset(0, 1)　とすると、「Rの領域を０行１列だけずらす」という意味になります。Rが A10 の場合、B10 を差すことになります。

さらに、.Resize(1, 3)をつけると、それを「１行３列に領域の範囲を変更」する、という意味になります。したがって、
R.Offset(0, 1).Resize(1, 3) は、「Rの１列隣のセルから１行３列の範囲」を意味し、Rが A10 の場合は B10:D10 という領域を指すことになります。

SearchRec の行の一番右にデータが入っているセルは、SearchRec.End(xlToRight)という式で求められます。その一つ右の空白セルにコピーするのですが、ここでも「指定した領域を１つずらす」という指定をするために.Offset(0,1)をつけています。
したがって、コピー先のセルの指定が、 SearchRec.End(xlToRight).Offset(0, 1) となります。

以上です。不明な点があれば補足願います。

お礼

ありがとうございます。
また解説までいただいて光栄です。
このマクロを利用すれば、仕事がはかどりそうです。
データ抽出したり、データ作成してから
差込データにするのに苦労しておりました。
これで本当に助かります。

回答No.3

maron--5

◆ANo.1です
◆番号でなくて事業所名でもいいですが、ただし同じ事業所は並んでかたまっていることが条件です

回答No.2

ham_kamo

マクロを書いてみました。
Alt+F11でVBAの画面を起動して、「挿入」＞「標準モジュール」を選択し、右の画面に以下のマクロを貼り付けて実行してみてください。
※マクロの中に出てくる"Sheet1","Sheet2"というシート名が実際には違う場合は実際のシート名に置きかえてください。

Sub データ加工()
　　Dim WS1 As Worksheet, WS2 As Worksheet
　　Dim R As Range, SearchRec As Range
　　Dim EndRow As Integer
　　Set WS1 = Worksheets("Sheet1")
　　Set WS2 = Worksheets("Sheet2")
　　EndRow = 0
　　WS2.UsedRange.ClearContents
　　For Each R In WS1.Range("A1", WS1.Range("A65536").End(xlUp))
　　　　Set SearchRec = WS2.Range("A:A").Find(R.Value)
　　　　If SearchRec Is Nothing Then 'はじめて出てきた場合
　　　　　　EndRow = EndRow + 1
　　　　　　R.Resize(1, 4).Copy WS2.Cells(EndRow, 1)
　　　　Else '既に出てきた場合
　　　　　　R.Offset(0, 1).Resize(1, 3).Copy SearchRec.End(xlToRight).Offset(0, 1)
　　　　End If
　　Next
End Sub

お礼

自分なりに工夫してみました。
フィールド数が５の場合（質問が４）
R.Resize(1, 5).Copy WS2.Cells(EndRow, 1)
　　　　Else '既に出てきた場合
　　　　　　R.Offset(0, 1).Resize(1, 4).Copy SearchRec.End(xlToRight).Offset(0, 1)
と２箇所書き換えれば応用が効くのでしょうか？
テストしてみて思い通り動いたのですが、意味が解らないので確認のためお教えいただければ幸いです。

補足

（完璧です。パーフェクトです。稼動確認も出来ました。）
お宅さまレベルでマクロとかも使いこなせれば
仕事もはかどることですね。
残念ながらマクロに記述された内容までは理解できませんが
私の意とすることを完全に理解されて下さって感謝いたします。
・・・実を言いますとフィールド数がもう少しあるのですが・・・・。
マクロのどの部分をどのように書き換えれば応用が効きますでしょうか？
お手数ですが、追加でご教示いただきますと幸いです。

回答No.1

maron--5

◆シート２のＡ列にあらかじめ、1,2,3とにゅうりょくをしておいて
◆シート２のＢ１の式
B1=IF(COLUMN(A1)>COUNTIF(Sheet1!$A:$A,$A1)*3,"",OFFSET(Sheet1!$A$1,MATCH($A1,Sheet1!$A:$A,0)+INT((COLUMN(A1)-1)/3)-1,MOD(COLUMN(C:C),3)+1))
★右と下にコピー

補足

早々の回答有難うございます。
質問欄で私の質問方法に誤りがありました。
Ａ列が連番で管理されていないので・・・
それでも可能なのでしょうか？
恐れ入りますが、ご教示いただければ幸いです。