Excel (VBA)

Excel VBAに関するフォーラムです。
  • 掲示板への投稿には会員登録(無料)が必要です。会員登録がまだの方はこちら
  • 掲示板ご利用上のお願い」に反するご記入はご遠慮ください。
  • Q&A掲示板の使い方はこちらをご覧ください
トピックに返信
質問

 
(Windows XP全般 : Excel 2003)
セルの値によって貼り付けるシートを振り分ける
投稿日時: 18/06/22 02:25:01
投稿者: kkkkkai

VBA初心者です。
以下のようなマクロを実行するコードをご教授頂けますでしょうか。
 
初歩的な質問かもしれませんが、教えていただけると幸いです。
 
 
ファイル名「顧客名簿」には、以下の通り会員顧客の情報が入力されています。
A列に「項番」
B列に「漢字氏名」
C列に「カナ氏名」
D列に「年齢」
E列に「会員ランク」
 
このファイルを次の通り別ファイルのシートに振り分けたいです。
 
@E列の値が「50以上」(50,100,150の3パターンがあります。)
     →A〜E列を別ファイル「会員ランク」のシート名「A」に貼り付け
AE列の値が「00」
     →A〜E列を別ファイル「会員ランク」のシート名「B」に貼り付け
 
なお、E列の値は50以上と00で固まって入力されてます。
 
E列
150
150
100
50
50
50
50
00
00
00
00
00
00

回答
投稿日時: 18/06/22 06:38:07
投稿者: simple

E列に見出し行があるとして、オートフィルターで抽出して、
それを別シートにコピーペイストする動作をマクロ記録すればどうですか?
範囲は全体を指定すればよく、絞り込まれた表示行だけがコピー対象となってくれます。
トライしてみて下さい。

回答
投稿日時: 18/06/23 13:27:46
投稿者: simple

色々な方法があると思います。
(1)オーソドックスに一行ずつ判定してコピーペイストする方法
(2)[このケースの特徴・特殊性を活かす方法]
  下から上にみて、50が最初に現れる行を探して、それをもとにまとめて転記する。
(3)オートフィルタ+転記
(4)フィルタオプションの利用
 
とりあえず(3)についてメモしますので参考にして下さい。
 
 
まず、
コードの部品を得るためだけなので、仮にSheet1のデータをSheet2とSheet3に振り分ける動作を
マクロ記録するとこんなものになるでしょう。(詳細はこだわらないでください。)
 

Sub Macro1()
    Range("E1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$E$7").AutoFilter Field:=5, Criteria1:="<>00*", _
        Operator:=xlAnd
    Selection.CurrentRegion.Select
    Selection.Copy
    Sheets("Sheet2").Select
    Range("A1").Select
    ActiveSheet.Paste
    Sheets("Sheet1").Select
    ActiveSheet.Range("$A$1:$E$7").AutoFilter Field:=5, Criteria1:="=00", _
        Operator:=xlAnd
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet3").Select
    Range("A1").Select
    ActiveSheet.Paste
    Sheets("Sheet1").Select
    Application.CutCopyMode = False
    Selection.AutoFilter
End Sub

これをもとにすると、こんなコードが作成できると思います。
 
Sub test()
    Dim ws1 As Worksheet
    Dim wsA As Worksheet
    Dim wsB As Worksheet
    Dim myRange As Range

    Set ws1 = Workbooks("顧客名簿").Worksheets("Sheet1")
    Set wsA = worksbooks("会員ランク").Worksheets("A")
    Set wsB = worksbooks("会員ランク").Worksheets("B")

    Set myRange = ws1.Range("A1").CurrentRegion
    myRange.AutoFilter Field:=5, Criteria1:="<>00*"    ' 00で始まらないもの
    myRange.Copy wsA.Range("A1")

    myRange.AutoFilter Field:=5, Criteria1:="00"    ' 00
    myRange.Copy wsB.Range("A1")
    myRange.AutoFilter
End Sub

参考にしてみてください。
# コードを下さい的な質問に、返事も無い中でコードを出すのはためらわれるが、
# 一方でこちらの時間が無駄になる気持ちもあります。
# データがまとまっているのだから普通は手作業で簡単にすますはずですが、
# 勉強材料と見てコメントしました。

トピックに返信