プロが教える店舗&オフィスのセキュリティ対策術

よろしくお願いいたします。
VBA初心者です。よろしくご指導をお願いいたします。
安易に教えてgooで質問することにお叱りをいただくこともあり、
VBAの本も数冊買って勉強をはじめ、格闘していますが、手に負えません。どうか助けてください。

  A     B   C   D   E    F   g
 担当者  日付 商品 規格 数量  単価 備考
1山田太郎  ○  △  ■   ◎  ◇   ▼
2鈴木次郎  ■  ○  ▼   ■  ○   ○
3佐藤三郎  △  ■  ○   ◎  ◎   ■
4山田太郎  ▼  ■  ◎   ■  ○   ▼
5山田太郎  ◇  ○  ◎   ◇  ◆   ◎
6鈴木次郎  ◆  ◎  ◇   ◎  ◇   ◇

というような入力シートの表があり、レコードは1000以上、下にたくさん続きます。
○や▼には実際には数値や商品名、短文などが入ります。

担当者は、50名、そこで「山田太郎」をはじめ、担当者氏名の名前の50のワークシートを作成しています。

そこで、次のようなVBAを書きたいのです。
VBAを実行すると、

シート別に入力表のデータが振り分けられて、
「山田太郎」に
 A  B   C   D   E    F   g
1  日付 商品 規格 数量  単価  備考
2  ○  △  ■   ◎  ◇    ▼
3  ▼  ■  ◎   ■  ○    ▼
4  ◇  ○  ◎   ◇  ◆    ◎
と入力シートに入力されたデータが50名のシートに振り分けられるものです。
どうか、よろしくご指導お願いいたします。

A 回答 (3件)

No.2です。

大変失礼しました。十分な確認ができてないまま投稿してしまいました。

TmpWS.Columns("A:A").Sort Key1:=Range("A2"), Header:=xlYes
の行を
TmpWS.Columns("A:G").Sort Key1:=Range("A2"), Header:=xlYes
に変更してください。やり直すときは、作成された担当者別のシートは削除してからでお願いします。
    • good
    • 0
この回答へのお礼

ありがとうございました。
完璧にできました^^
心より感謝申し上げます。
初心者ながら、なぜ、最初のコードではできなかったかも理解できました。並び替えがデータ全体に及んでなかっただけですね。
本当に、本当にありがとうございました。
こんなに素敵なコードが書けるように私も勉強していきたいです。

お礼日時:2007/01/15 22:00

マクロを書いてみました。


一度シートを作業用にコピーし、担当者別にソートしてから他のシートに振り分け、最後に作業用シートを削除しています。
「挿入」>「標準モジュール」を選択して、以下のマクロを貼り付けて実行してください。
マクロ中の"Sheet1"という部分は、実際に元データが入っているシート名に変更してください。

Sub 担当者別に振り分け()
  Dim OrgWS As Worksheet, TmpWS As Worksheet, CurWS As Worksheet
  Dim FromCell As Range
  Dim ToCellNum As Integer
  Dim CurName As String
  
  '変数初期化
  Set OrgWS = Worksheets("Sheet1") '元のデータがあるシート名を指定
  CurName = ""
  
  '処理終了まで描画を止める
  Application.ScreenUpdating = False
  
  'シートを作業用にコピーして担当者でソート
  OrgWS.Copy after:=Sheets(Worksheets.Count)
  Set TmpWS = Worksheets(Worksheets.Count)
  TmpWS.Columns("A:A").Sort Key1:=Range("A2"), Header:=xlYes
  
  'メイン処理
  For Each FromCell In TmpWS.Range("A2", TmpWS.Range("A65536").End(xlUp))
    If FromCell.Value <> CurName Then '次の担当者に移った場合
      CurName = FromCell.Value
      Worksheets.Add after:=Worksheets(Worksheets.Count) 'シートを最後に追加
      Set CurWS = Worksheets(Worksheets.Count)
      CurWS.Name = CurName 'シート名を担当者にする
      ToCellNum = 2 'コピー先セルの行番号を初期設定
      OrgWS.Range("B1", "G1").Copy CurWS.Range("A1") 'タイトル行をコピー
    End If
    FromCell.Offset(0, 1).Resize(1, 6).Copy CurWS.Cells(ToCellNum, 1) 'データのコピー
    ToCellNum = ToCellNum + 1 'コピー先セルを一つ下に進める
  Next
  
  '作業用シートを削除
  Application.DisplayAlerts = False
  TmpWS.Delete
  Application.DisplayAlerts = True
  
  '描画を再開
  Application.ScreenUpdating = True

End Sub

この回答への補足

早速のご回答ありがとうございます。
やはり、私の手におえないものでした。
まずは、コードを感謝いたします。

まず、担当者シートは瞬時にできました。感謝です。
ところが、振り分けが担当者別に正しくなされませんでした。
どこで不具合を起こしているのか、わかりません。
どうか、続けてのご指導をお願いいたします。

補足日時:2007/01/15 21:26
    • good
    • 1

コードの流れは参考URLのNo.1さんの回答が参考になると思います。


まだ自力では・・・というようでしたら補足してください。

参考URL:http://oshiete1.goo.ne.jp/qa2662756.html

この回答への補足

アドバイスをありがとうございます。
なるほど、そっくりの質問、ご回答があったのですね。

No.1さんのコードの流れの解説は概ね理解できました。
ところが、私のスキルがマクロを自動記録させて修正、応用する程度なので、やはり新規コードを書くことは困難ですし、本を開いても、まださっぱりです。

もし、可能なら続けてご指導いただけますでしょうか?
ただ、No.2さんと並行してご指導依頼をしていますことをお許しくださいませ。

補足日時:2007/01/15 21:42
    • good
    • 0
この回答へのお礼

ありがとうございました。NO.2さんで完全解決いたしました。
もし、コードなど書いていただいていた途中なら申し訳ありません。
ただ、アドバイスくださいましたことを、心より感謝いたします。
ありがとうございました。

お礼日時:2007/01/15 22:30

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!