Excel2000 データの振り分けと配列変換について

質問

シート１にデータを一気に入力してあります。
第１段階、所属ごとに所属１は所属１のシート、所属２は所属２のシートというようにシートに振り分けをしたい。
第２段階、振り分け後データごとに２列になるように印刷をしたい。

この様に入力されているデータを
Ａ　　　Ｂ　　　Ｃ　　　Ｄ
番号　名前　　　所属
　１　ＡＡＡ　　１
　２　ＢＢＢ　　２
　３　ＣＣＣ　　１
　４　ＤＤＤ　　３
　５　ＥＥＥ　　４
　６　ＦＦＦ　　５
　７　ＧＧＧ　　６
　８　ＨＨＨ　　３
　９　ＩＩＩ　　４
１０　ＪＪＪ　　６
　・
　・
　・

所属ごとにシートに振り分けて、２列　任意の単位で（この場合では、５単位ごと）になるように印刷したい。
所属１のシート
番号　名前　　　所属　番号　名前　　　所属
　１　ＡＡＡ　　１　　　６　ＦＦＦ　　１
　２　ＢＢＢ　　１　　　７　ＧＧＧ　　１
　３　ＣＣＣ　　１　　　８　ＨＨＨ　　１
　４　ＤＤＤ　　１　　　９　ＩＩＩ　　１
　５　ＥＥＥ　　１　　１０　ＪＪＪ　　１

技が無いため、切り張りしていますが、なにか良い方法がありましたら教えてください。

回答No.4

ARC

ども。遅くなりました。
とりあえず、結論から書くと、先のマクロを修正して、以下のような感じにします。
(シングルコーテーションより後ろの部分は、「コメント」で、マクロの動作には一切影響を与えません。)

Sub 段組()
　Dim MaxRow As Long 'シートの最大行数を格納する変数
　Dim AddressStr As String 'アドレス名を格納する変数

'ここから
　Sheets("所属1").Select　'所属1を選択
　Range("A1:C1").Select　 'タイトル行(A1:C1)を選択
　Selection.Copy　　　'コピーして
　Range("E1").Select　　'E1を選び
　ActiveSheet.Paste　　 '貼り付け

　MaxRow = ActiveSheet.UsedRange.Rows.Count 'シートの最大行数を取得して
　AddressStr = "A" & Int(MaxRow / 2) + 2 & ":C" & MaxRow　'それをもとに切り取る範囲を計算
　Range(AddressStr).Select　'計算で得られた範囲を選択

　Application.CutCopyMode = False
　Selection.Cut　　　 '切り取って
　Range("E2").Select　　'E2を選択
　ActiveSheet.Paste　　 '貼り付け
'ここまでをシートの数だけ繰り返す
End Sub

この後、「ここから」と「ここまで」の部分をコピーして、「所属」の数だけ貼り付けます。
で、
　Sheets("所属1").Select
の行の"所属1"の部分を、それぞれのシートの名前に変更してやれば完成です。

先の操作を記録したマクロとの変更内容は、
・先頭部分に２行(Dim … を付け加えた。)

・Range("A26:C49").Select
　の部分を
　MaxRow = ActiveSheet.UsedRange.Rows.Count
　AddressStr = "A" & Int(MaxRow / 2) + 2 & ":C" & MaxRow
　Range(AddressStr).Select
　に書き直した。
です。

簡単に説明してみますと、
Dim … の行は、「これから、○○という『変数』を使う。」ということを「宣言」しています。

MaxRow = … の行は、そのワークシートに何行分データが入力されているのかを調べています。
和訳すると、アクティブなワークシートの、現在使われている範囲の、行数の、カウントを、「MaxRow」という変数に代入する。です。

AddressStr = … の行は、"A26:C49"という文字列を、計算によって作り出しています。
"A", 26, ":C", 49 を 『&』を使って結合しています。
「26」の部分は、「最大行数を２で割って、端数を切り捨てた後、２を加える」という計算で算出しています。

※マクロとしての完成度は、#3,nishi6さんの作品の方が高そうですので、「分かり易さ」を意識して書いてみたんですが、どんなもんでしょ？

お礼

ありがとうございました。
また、分からない点がでてきましたら教えてください。

回答No.3

nishi6

所属単位の印刷が目的と解釈しましたので下記のコードを書いてみました。入力シートを直接参照して印刷することも可能ですが、コードが長くなるので１回並び替えを行なったデータを使って印刷します。

（１）別のシートに入力データをコピーして所属で並び替えます。
（２）並び替えたシートの"番号"が入れてあるセルに名前"top"を付けます。
（３）別シートに印刷する表を作ります。印刷範囲を設定し、データ部分（５×６のセル）に名前"prtData"を付けます。（名前は私が勝手に付けたものです）
（４）VBE画面で標準モジュールを挿入し、下記のコードを貼り付けます。
（５）印刷する表のあるシートからマクロ"INSATU"を実行します。

今は印刷プレビューにしてあります。ActiveSheet.PrintPreview のPrintPreviewをPrintOutに変えれば印刷できると思います。行方向に何行あってもかまいません。
印刷する表の形によって"TATE"、"YOKO"の値を変更すれば任意の縦横の表が印刷できます。実際は縦は何十行かあるのでしょうか。この変更を不要とするコードも書けますが今回は行っていません。蛇足ですが、所属は共通なので表の外に出すのも一案では？その場合はコードを少し変える必要がありますが。がんばって下さい。

Option Explicit

Public Sub INSATU()
Dim rg1 As Range '入力データ基準位置
Dim rg2 As Range '出力データ
Dim cot As Long '入力データカウンタ
Dim Pcot As Integer '出力データカウンタ
Dim Ecot As Integer '出力データ要素カウンタ
Dim TATEpot, YOKOpot As Integer '書き出す位置
Dim OldSyozoku As Variant '前回の所属
Dim NewSyozoku As Variant '今回の所属
Const TATE = 5 '出力の行数
Const YOKO = 2 '出力の列数(ELMT列が１)
Const ELMT = 3 'データの要素数
Set rg1 = Range("top")
Set rg2 = Range("prtData")
cot = 1
'データがなくなるまで読み込む
Do While rg1.Offset(cot, 0) <> ""
Pcot = Pcot + 1
NewSyozoku = rg1.Offset(cot, 2)
'印刷判定
If cot <> 1 And OldSyozoku <> NewSyozoku Then
ActiveSheet.PrintPreview 'PrintOut
rg2.ClearContents: Pcot = 1
Else
If Pcot > TATE * YOKO Then
ActiveSheet.PrintPreview 'PrintOut
rg2.ClearContents: Pcot = 1
End If
End If
'出力の位置計算と出力
TATEpot = (Pcot - 1) Mod TATE + 1
YOKOpot = (Int((Pcot - 1) / TATE)) * ELMT + 1
For Ecot = 0 To ELMT - 1
rg2.Cells(TATEpot, YOKOpot).Offset(0, Ecot) = rg1.Offset(cot, Ecot)
Next
OldSyozoku = NewSyozoku
cot = cot + 1 'カウンタを進める
Loop
ActiveSheet.PrintPreview 'PrintOut
End Sub

お礼

内容が理解できるよう勉強していきたいと思います。
ありがとうございました。

回答No.2

ARC

どもども

>簡単な記録式のマクロしか使ったことがありませんが…
一応、今回も基本はマクロの記録を使います。

第一段階
準備
1:A列からC列までを選択し、[データ]-[フィルタ]-[オートフィルタ]を実行する
2:あらかじめ、所属分のシートを作っておく(S所属1,S所属2,S所属3…と名前を付ける)

マクロの記録を開始して、以下のような感じのマクロを記録する

1:S所属1を選択
2:すべてのセルを選択し、[Delete]キーでデータを削除
3:Sheet1を選択
4:[所属]の▼をクリックし、1を選択
5:A列からC列までを選択
6:コピー
7:S所属1のA1のセルをクリックして、貼り付け
8:以上の操作を、所属の数だけ繰り返す

第二段階については、段組にする際の分岐点の位置が毎回異なるため、これをその都度計算してやる必要があります
。
とりあえず、マクロを記録を使って、記録してみたのが以下の内容です。
(所属1に関してのみ、段組を行った)
実際にマクロを記録してみて、マクロメニューから[編集]してみてください。

Sub 段組()
　Sheets("S所属1").Select 'S所属1を選択
　Range("A1:C1").Select 'タイトル行(A1:C1)を選択
　Selection.Copy　　 'コピーして
　Range("E1").Select　 'E1を選び
　ActiveSheet.Paste　 '貼り付け
　Range("A26:C49").Select '※全部で49行あったので、中間点となる26行目以降を選択
　Application.CutCopyMode = False
　Selection.Cut　　 '切り取って
　Range("E2").Select　 'E2を選択
　ActiveSheet.Paste　 '貼り付け
End Sub

次回、この内容を改良してみます。
ってことで、また明日か明後日にでも書き込みます!

回答No.1

ARC

第１段階の方は、まず、[所属]項目で並べ替えを行ってから、コピー・ペーストすれば作業効率が上がると思います。

で、これらの操作を、コピー・ペーストを用いないで何とかしたいとのことなんですが、第1段階にせよ、第2段階にせよ、切り貼りの範囲がその時々によって異なってくるので、関数を用いたやり方はかなり難しいと思います。

マクロを使ってやれば十分可能な処理ですので、もしマクロを使ってでも何とかしたいというのであれば、「補足」をお願いします。

補足

簡単な記録式のマクロしか使ったことがありませんが、これを機に勉強したいと思います。よろしくお願いします。