COUNTER



新BLOG
 
新BBS
MN-BBS
旧BBS
CALENDAR
S M T W T F S
          1 2
3 4 5 6 7 8 9
10 11 12 13 14 15 16
17 18 19 20 21 22 23
24 25 26 27 28 29 30
31       
<<  2024 - 03  >>
 
LOGIN
現在モード: ゲストモード
USER ID:
PASS:
CATEGORIES
ARCHIVES
PROFILE
OTHERS
    処理時間 0.266945秒
POWERED BY
POWERED BY
ぶろぐん
DESIGN BY
ブログンサポート
          
---手強しエクセルVBA---
 在宅でお手伝いをしている仕事関連で、エクセルでの処理を

 手短にやろうと、久しぶりにエクセルのVBAをいじりました。

 やることは、

  原本
  ↓
  シートのコピー
  ↓
  振分してシートごとに転記
  ↓
  コピーの削除

 これだけですが、0から作ることはできないので、NETと検索

 するとちょうどVBAのプログラムがでていました。

   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:G").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

 でした。すぐ動くかとおもいましたが、エラーでだめでした。

 ネットで検索をしながら、やっと、動くように手直ししました。

 動かなかったのは、多分、掲載してあったVBAは、2003用の

 古いものだったのかもしれません。2013では、動きませんでした。

 下記が、修正して、私の環境で動くようにしたものです。

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("一覧") '元のデータがあるシート名を指定
    CurName = ""

  '処理終了まで描画を止める
  Application.ScreenUpdating = False

  'シートを作業用にコピーして担当者でソート
    OrgWS.Copy after:=Sheets(Worksheets.Count)
    Set TmpWS = Worksheets(Worksheets.Count) '最後ワークシートを作業用に
    TmpWS.Activate
    TmpWS.Range("B2:I17").Sort Key1:=TmpWS.Range("C3"), order1:=xlAscending, Header:=xlYes


  'メイン処理
    For Each FromCell In TmpWS.Range("C3", TmpWS.Range("C" & Rows.Count).End(xlUp))

      If FromCell.Value = "終了" Then Exit For

      If FromCell.Value <> CurName Then
        CurName = FromCell.Value
        Worksheets.Add after:=Worksheets(Worksheets.Count) 'シートを最後に追加
        Set CurWS = Worksheets(Worksheets.Count)
        CurWS.Name = CurName 'シート名を種別名にする
        ToCellNum = 1 'コピー先セルの行番号を初期設定
        OrgWS.Range("B1", "I2").Copy CurWS.Range("B2") 'タイトル行をコピー
      End If

      ToCellNum = ToCellNum + 1 'コピー先セルを一つ下に進める
      FromCell.Offset(0, -1).Resize(1, 8).Copy CurWS.Cells((ToCellNum + 2), 2) 'データのコピー

    Next

  '作業用シートを削除
    Application.DisplayAlerts = False
    TmpWS.Delete
    Application.DisplayAlerts = True

  '描画を再開
    Application.ScreenUpdating = True

End Sub

  作業シートの作製までは、うまくいったのですが、このシート

  をソートしようと思っても、原本がソートされ、ここを直すのに

  まる一日以上かかってしまいました。

  目が疲れました。 Webはくしゅ

| mabo52 | 15:00 | comments (0) | trackback (0) | WIN関連 |
コメント

コメントする









この記事のトラックバックURL
http://mabo52.sakura.ne.jp/tb.php/1003
トラックバック

こんな物欲しいな
CLOCK
NEW ENTRIES
COMMENTS
    ---SPINDLEのPWM制御 (その2) (7)
  • TR >06.18
    ---番外編---
  • TR >06.02
    ---SPINDLEのPWM制御 (その2) (5)
  • mabo >05.30
保留中コメント:10件
LINKS
    相互リンクさせていただいてます。
  • The Rider
Search Box
名言集
メール
   
連絡は下記から
名前:

メールアドレス:

件名:

メッセージ(必須):


TOP PAGE