---手強しエクセル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

  作業シートの作製までは、うまくいったのですが、このシート
  をソートしようと思っても、原本がソートされ、ここを直すのに
  まる一日以上かかってしまいました。
  目が疲れました。 

コメントを残す

メールアドレスが公開されることはありません。 が付いている欄は必須項目です

CAPTCHA