Excel VBA で条件を満たしたセルの値を別のシートに貼り付けるには？

質問

VBA初心者です。700行くらいあるリストの中から所属別の名簿を作りたいのですが、マクロを使えば簡単に出来ますか？

データは、　A列にNO.、B列に氏名、C列に所属　となっていて、C列の所属ごとにSheet2,Sheet3・・・にB列の氏名だけの名簿を作りたいのです。
例えば、C列が”総務課”の人の氏名（B列）をSheet2のCell("A2")から行方向に、C列が”会計課”の人の氏名はSheet3のCell("A2"）から行方向に　という感じです。
Do～Loop を使ってみたり、If～Then　を使ってみたりするのですがうまく貼り付けられません。
データの最終行が変化するので範囲の指定もよく分かりません。
どなたか教えて下さい。

回答No.4

papayuka · ベストアンサー

#3です。

> できますか？

出来るでしょうね。
抜き出し処理が同じなら、コピー＆貼り付け部分を見直せば良い訳です。
ただ、仕様が見えない部分もあり、何処までやるかで処理の難易度も大幅に変わります。

任意のシートには先月のデータがあるのでしょうから、これをどう扱うか。
先月のデータは消してしまい、一覧のソート順は毎回同じで、課の統廃合などによる増減が絶対に無いならそれ程でも無いでしょうけど、一覧のソート順が変わる「可能性がある」というだけで、任意シートの貼り付け先を探して処理をしないといけませんし、課が発足したら任意シートに追加しないといけないなど、例外的な処理も多くなります。

丸投げで「これも作って」では知識も向上しないですし、自分なりに挑戦して、どうしても不明な部分に絞って質問されては如何でしょう？

---

と、、、突き放すだけというのも何ですので参考として、新規ブックに列展開の例を。

Sub Test1()
Dim tws As Worksheet, ws As Worksheet
Dim r As Range, ro As Range, tr As Range
　Set tws = ActiveSheet
　Set r = tws.Range("C2"): Set ro = r.Offset(1, 0)
　Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
　Do While r.Value <> ""
　　　Do While r.Value = ro.Value
　　　　 Set ro = ro.Offset(1, 0)
　　　Loop
　　Set tr = ws.Range("IV1").End(xlToLeft).Offset(0, 1)
　　tr.Value = r.Value
　　tws.Range(r.Offset(0, -1), ro.Offset(-1, -1)).Copy _
　　　　　　　　　　Destination:=tr.Offset(1, 0)
　　Set r = ro
　Loop
　ws.Columns(1).Delete
　With ws.Range("A1").CurrentRegion
　　　 .Offset(.Rows.Count, 0).Resize(1) = _
　　　　　　　　　　"=counta(A2:A" & .Rows.Count & ")"
　End With
End Sub

お礼

ありがとうございました。＆ごめんなさい（>_<）もう少し自分で考えてから質問するべきですよね。私が何日やっても出来なかったことを、すぐに回答してもらえたので、ついつい・・・。もっとベ勉強します。

回答No.3

papayuka

つい最近、ここで同じような質問に答えました。
C列でソートされているとして。

Sub Test()
Dim tws As Worksheet, ws As Worksheet
Dim r As Range, ro As Range, LRow As Long
　Set tws = ActiveSheet
　Set r = tws.Range("C2"): Set ro = r.Offset(1, 0)
　Do While r.Value <> ""
　　　Do While r.Value = ro.Value
　　　　 Set ro = ro.Offset(1, 0)
　　　Loop
　　Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
　　On Error Resume Next
　　ws.Name = r.Value
　　tws.Range("B1").Copy Destination:=ws.Range("A1")
　　tws.Range(r.Offset(0, -1), ro.Offset(-1, -1)).Copy _
　　　　　　　　　　Destination:=ws.Range("A2")
　　Set r = ro
　Loop
End Sub

お礼

大変ありがとうございました。シート名まで変わるので感激しました！僕にはチョット難しい構文ですが、ところどころ変えて使ってみます。

補足

ところで、もう一つ教えていただけませんでしょうか？

同じ一覧を使って、部署ごとに抜き出すのは一緒なのですが、今度はシートを増やしていくのではなく任意のシートにA列は総務課、B列は会計課、C列は施設課という具合に列方向へ名簿を展開したいのです。そして、それぞれの部署の合計人数を最後のセルに入るようにしたいのですが、できますか？
毎月、月初めに処理をするので、上書きをしていきたいのです。お手数でしょうが、どうかよろしくお願いします。

回答No.2

cma3atgoo

途中に空白の項目がないのならば、
do while (Cells(Row,Col).Value <> "" )

loop
などとして1セルずつ（または1行ずつ）コピーしてみてはどうでしょうか？
空白があったら途中で終わってしまいますけどね。

お礼

回答、ありがとうございました。

回答No.1

134

もちろんＶＢＡを使っても出来ますけど…

オートフィルターで部署ごとの名簿を表示して、コピー範囲を指定。　その後、貼りつけ先のシートを選んで、「値のみ」「行列を入れ替える」で貼りつけても、良いのかなと思いました。

ちなみに、最終行を取得するには、
n=range("A6554").end(xlup).rows.count
とすると、最後の行までの行数を数えてくれます。