タスク整理マクロ

　Microsoft Projectのタスクの切り方がまずかったから、進捗報告のためにExcel上でデータを操作するためのマクロです。これもそのまま使えるわけではありませんが、マクロでの検索の使い方などが参考になるため、掲載しておきます。

Sub main()

   Dim c As Object

   Dim sSlot() As String
   Dim sRyoiki() As String
   Dim sTitle() As String
   Dim sAddon() As String
   Dim sKinou() As String
   Dim sBefore() As String
   Dim sAfter() As String

   Dim lRow As Long
   Dim lCol As Long
   Dim lIndex As Long

   Dim sRange As String
   Dim sSheet As String
   Dim sAddress As String

   sSheet = "作業用シート"
   sRange = "E2:E65536"

   ReDim sSlot(4)
   sSlot(1) = "スロット1"
   sSlot(2) = "スロット2"
   sSlot(3) = "スロット3"
   sSlot(4) = "スロット4"

   ReDim sRyoiki(3)
   sRyoiki(1) = "生産"
   sRyoiki(2) = "購買・販売"
   sRyoiki(3) = "原価・業績"

   ReDim sTitle(3)
   sTitle(1) = "スロット"
   sTitle(2) = "領域"
   sTitle(3) = "アドオン"

   ReDim sAddon(1)
   sAddon(1) = "*_*"

   ReDim sKinou(1)
   sKinou(1) = "機能設計"

   ReDim sBefore(7)
   sBefore(1) = "要件部"
   sBefore(2) = "仕様部"
   sBefore(3) = "機能設計レビュー"
   sBefore(4) = "クライアントサインオフ"
   sBefore(5) = "機能設計トランジション"
   sBefore(6) = "技術設計・構築"
   sBefore(7) = "受入テスト"

   ReDim sAfter(7)
   sAfter(1) = "01 要件部"
   sAfter(2) = "02 仕様部"
   sAfter(3) = "03 機能設計レビュー"
   sAfter(4) = "04 クライアントサインオフ"
   sAfter(5) = "05 機能設計トランジション"
   sAfter(6) = "06 技術設計・構築"
   sAfter(7) = "07 受入テスト"

   '画面更新OFF
   Application.ScreenUpdating = False

   '列の挿入とeofの入力
   Call WriteTitle(sSheet, sTitle)

   '全体をコピーして値のみ貼り付け
   Call PasteSpecial(sSheet)

   '文字列を置換
   Call ReplaceRepeat(sSheet, sRange, sBefore, sAfter, 7)

   'スロットを探してコピー
   Call FindCopyCells(sSheet, sRange, sSlot, 4, 3)

   'コピーを繰り返す
   Call CopyRepeat(2, 2)

   'スロットを探して削除
   Call DeleteRow(sSheet, sRange, sSlot, 4)

   '領域を探してコピー
   Call FindCopyCells(sSheet, sRange, sRyoiki, 3, 2)

   'コピーを繰り返す
   Call CopyRepeat(2, 3)

   '領域を探して削除
   Call DeleteRow(sSheet, sRange, sRyoiki, 3)

   'アドオン（"_"の入っている項目）を探してコピー
   Call FindCopyCells(sSheet, sRange, sAddon, 1, 1)

   'コピーを繰り返す
   Call CopyRepeat(2, 4)

   'アドオン（"_"の入っている項目）を探して削除
   Call DeleteRow(sSheet, sRange, sAddon, 1)

   '"機能設計"を探して削除
   Call DeleteRow(sSheet, sRange, sKinou, 1)

   'コピーや切取りの操作を解除
   Application.CutCopyMode = False

   '画面更新ON
   Application.ScreenUpdating = True

End Sub

'No.1 「sFind()」で指定した文字列を「sSh」シートの「sRa」の範囲から検索し、
'「lDiff」列だけ左にずらしてコピーすることを「lEnsNum」回（配列の次元）だけ繰り返す
Sub FindCopyCells(sSh As String, sRa As String, sFind() As String, lEndNum As Long, lDiff As Long)

   Dim lRow As Long
   Dim lCol As Long
   Dim lNum As Long
   Dim sAddress As String
   Dim c As Object

   '以前に実行したコピーや切取りの操作を無効にする
   Application.CutCopyMode = False

   For lNum = 1 To lEndNum
      '対象のワークシートおよび範囲を指定
      With Worksheets(sSh).Range(sRa)
         '上記のワークシート内でsFind()を検索しオブジェクトを取得する
         Set c = .Find(What:=sFind(lNum), LookIn:=xlValues, lookat:=xlWhole, _
                     SearchOrder:=xlByColumns, MatchByte:=False)

         '取得したオブジェクトをコピーして、指定したセルに値だけ貼りつける
         If Not c Is Nothing Then
            sAddress = c.Address
            Do
               lRow = c.row
               lCol = c.Column
               c.Copy

               '値だけ貼りつけるオプションつき
               Cells(lRow, lCol - lDiff).PasteSpecial Paste:=xlPasteValues

               '検索を継続する（次の検索）
               Set c = .FindNext(c)

               '最初に検索したセルに到達するまで繰り返す
               If c.Address = sAddress Then Exit Do
            Loop
         End If

         Set c = Nothing
      End With
   Next lNum

   '以前に実行したコピーや切取りの操作を無効にする
   Application.CutCopyMode = False

End Sub

'No.2 指定したセル（lRw,lCo）Aから、次に空白以外が入力されたセルBを探し、
'AとBの間にあるセルに、Aの値を貼りつける
'Bから次の空白以外が入力されたセルCを探し、同じように貼りつける
'eofが入力されたセルに到達すると終了する
Sub CopyRepeat(lRw As Long, lCo As Long)

   Dim lEndRow As Long

   '以前に実行したコピーや切取りの操作を無効にする
   Application.CutCopyMode = False

   '次の空欄前の行を取得（CTRL+↓）
   lEndRow = Cells(lRw, lCo).End(xlDown).row

   While Cells(lEndRow, lCo).Value <> "eof"
      '次の空白以外の入力された行を取得（CTRL+↓）
      lEndRow = Cells(lRw, lCo).End(xlDown).row

      '基点となったセルの値をコピーする
      Cells(lRw, lCo).Copy

      '基点となったセルから、上記で取得したセルの間までに値を貼りつける
      Range(Cells(lRw, lCo), Cells(lEndRow - 1, lCo)).PasteSpecial Paste:=xlPasteValues

      '上記で取得したセルに移動する
      Cells(lEndRow, lCo).Select

      'セル情報取得
      lRw = Cells(lEndRow, lCo).row
      lCo = Cells(lEndRow, lCo).Column
   Wend

   '以前に実行したコピーや切取りの操作を無効にする
   Application.CutCopyMode = False

End Sub

'No.3 「sFind()」で指定した文字列を「sSh」シートの「sRa」の範囲から探し、その行を削除する
Sub DeleteRow(sSh As String, sRa As String, sDel() As String, lEndNum As Long)

   Dim lRow As Long
   Dim lCol As Long
   Dim lNum As Long
   Dim c As Object

   '以前に実行したコピーや切取りの操作を無効にする
   Application.CutCopyMode = False

   For lNum = 1 To lEndNum
      '対象のワークシートおよび範囲を指定
      With Worksheets(sSh).Range(sRa)
         '上記のワークシート内でsFind()を検索しオブジェクトを取得する
         Set c = .Find(What:=sDel(lNum), LookIn:=xlValues, lookat:=xlWhole, _
                     SearchOrder:=xlByColumns, MatchByte:=False)

         '取得したオブジェクトの行を削除し、次の検索を実行し、同様に削除する
         If Not c Is Nothing Then
            Do
               lRow = c.row
               Rows(lRow).Delete

               '検索を繰り返す
               Set c = Worksheets(sSh).Range(sRa).Find(What:=sDel(lNum), LookIn:=xlValues, lookat:=xlWhole, _
                                             SearchOrder:=xlByColumns, MatchByte:=False)

            '対象のオブジェクトが見つからなくなるまで続ける
            Loop While Not c Is Nothing
         End If

         Set c = Nothing
      End With
   Next lNum

   '以前に実行したコピーや切取りの操作を無効にする
   Application.CutCopyMode = False

End Sub

'2列目から3列挿入し、1行目に項目を入力して、最終行の下に「eof」を入力する
Sub WriteTitle(sSh As String, sVal() As String)

   Dim lEndRow As Long
   Dim lEndCol As Long
   Dim lNum As Long

   '「sSh」シートをアクティブにする
   Worksheets(sSh).Activate

   '2列目から3列挿入する
   Worksheets(sSh).Range(Columns(2), Columns(4)).Insert

   '1行目に項目を入力する
   Worksheets(sSh).Cells(1, 2).Value = sVal(1)
   Worksheets(sSh).Cells(1, 3).Value = sVal(2)
   Worksheets(sSh).Cells(1, 4).Value = sVal(3)

   '基点となるセル（原点）を選択する
   Worksheets(sSh).Cells(1, 1).Select

   '次の空白行の手前まで下にとぶ
   lEndRow = Worksheets(sSh).Cells(1, 1).End(xlDown).row

   '次の空白列の手前まで右に飛ぶ
   lEndCol = Worksheets(sSh).Cells(1, 1).End(xlToRight).Column

   '最終行の下に「eof」を入力する
   For lNum = 1 To lEndCol
      Worksheets(sSh).Cells(lEndRow + 1, lNum) = "eof"
   Next lNum

End Sub

'置換前後の文字列を渡し、指定したシートの範囲内で、対象文字列がなくなるまで置換を繰り返す
Sub ReplaceRepeat(sSh As String, sRa As String, sBe() As String, sAf() As String, _
               lRep As Long)

   Dim c As Object
   Dim lNum As Long

   '以前に実行したコピーや切取りの操作を無効にする
   Application.CutCopyMode = False

   For lNum = 1 To lRep
      '対象のワークシートおよび範囲を指定
      With Worksheets(sSh).Range(sRa)

         '上記のワークシート内でsFind()を検索しオブジェクトを取得する
         Set c = .Find(What:=sBe(lNum), LookIn:=xlValues, lookat:=xlWhole, _
                     SearchOrder:=xlByColumns, MatchByte:=False)

         '検索語句が存在する場合には、文字列置換を実行
         If Not c Is Nothing Then
            Do
               '上記のワークシートおよび範囲内で文字列を置換する
               .Replace What:=sBe(lNum), Replacement:=sAf(lNum), _
                           SearchOrder:=xlByColumns, MatchByte:=False

               '検索を続行
               Set c = .FindNext(c)

            '検索語句が存在する間、置換を繰り返す
            Loop While Not c Is Nothing
         End If

         'オブジェクトを開放
         Set c = Nothing
      End With
   Next lNum

End Sub

'値のある範囲を指定し、同じ場所に値のみコピーする
Sub PasteSpecial(sSh As String)

   Dim lEndRow As Long
   Dim lEndCol As Long
   Dim lNum As Long

   '「sSh」シートをアクティブにする
   Worksheets(sSh).Activate

   '基点となるセル（原点）を選択する
   Worksheets(sSh).Cells(1, 1).Select

   '次の空白行の手前まで下にとぶ
   lEndRow = Worksheets(sSh).Cells(1, 1).End(xlDown).row

   '次の空白列の手前まで右に飛ぶ
   lEndCol = Worksheets(sSh).Cells(1, 1).End(xlToRight).Column

   '値のある範囲をコピー
   Worksheets(sSh).Range(Cells(1, 1), Cells(lEndRow, lEndCol)).Copy

   'コピーした範囲を値のみ貼り付け
   Worksheets(sSh).Range(Cells(1, 1), Cells(lEndRow, lEndCol)).PasteSpecial Paste:=xlPasteValues

   '以前に実行したコピーや切取りの操作を無効にする
   Application.CutCopyMode = False

End Sub

'シート間の範囲内のコピー
Sub Sheet2Sheet(sShFr As String, sShTo As String)

   Dim lEndRow As Long
   Dim lEndCol As Long
   Dim lNum As Long

   'コピー先のシートをタイトル行を除いて空にする
   Worksheets(sShTo).Rows("2:65536").Delete

   '「sShFr」シートをアクティブにする
   Worksheets(sShFr).Activate

   '基点となるセル（原点）を選択する
   Worksheets(sShFr).Cells(1, 1).Select

   '次の空白行の手前まで下にとぶ
   lEndRow = Worksheets(sShFr).Cells(1, 1).End(xlDown).row

   '次の空白列の手前まで右に飛ぶ
   lEndCol = Worksheets(sShFr).Cells(1, 1).End(xlToRight).Column

   '値のある範囲をコピー
   Worksheets(sShFr).Range(Cells(2, 1), Cells(lEndRow - 1, lEndCol)).Copy

   '「sShTo」シートをアクティブにする
   Worksheets(sShTo).Activate

   'コピーした範囲を貼り付け
   Worksheets(sShTo).Range(Cells(2, 1), Cells(lEndRow - 1, lEndCol)).PasteSpecial

   '以前に実行したコピーや切取りの操作を無効にする
   Application.CutCopyMode = False

End Sub

'指定したシートの1行目から指定した文字列を検索し、該当列の行数を調べ、
'該当列の最終行のセルの行と列の値を返す
Function DefineRange(sSh As String, sFind As String) As Long()

   Dim lRange() As Long
   Dim lRo As Long
   Dim lCo As Long

   ReDim lRange(2)

   '対象のワークシートおよび1行目を指定
   With Worksheets(sSh).Range("A1:IV1")
      '上記のワークシート内でsFindを検索しオブジェクトを取得する
      Set c = .Find(What:=sFind, LookIn:=xlValues, lookat:=xlWhole, _
                  SearchOrder:=xlByColumns, MatchByte:=False)

      lRo = c.row
      lCo = c.Column

      Set c = Nothing

      '基点となるセルを選択する
      Cells(1, lCo).Select

      '次の空白行の手前まで下にとぶ
      lRo = Cells(1, lCo).End(xlDown).row

   End With

   lRange(1) = lRo
   lRange(2) = lCo

DefineRange = lRange

End Function

ホーム