自動でExcelの表を加工して別ファイルとして作成する

2022年2月2日

EXCELの表を加工して新たに別なファイルとして表を作成する場合、同じ内容で繰り返し作成する業務あればVBAを利用することにより、ボタン一発で作業を完了させることができます。
今回はあるEXCELの表を新規に別ファイルの表として作成方法をご紹介します。

サンプルアプリ実行結果

「別ファイルとして表を作成」ボタンをクリックすると、「別表.xslx」ファイルが新規に作成され、社員番号と名前、通勤手当を抜き出した新たな表が作成されます。

サンプルコードの処理内容

社員一覧表の中から社員番号、氏名、通勤手当の項目だけを取り出して別ファイルとして表を作成します。
作成手順の大まかな流れは以下のようになります。

新規ファイル作成先を指定（今回は作成元ファイルがあるフォルダを指定）
　　　↓
新規ファイル名を指定
　　　↓
作成元表から新規に作成する表項目のデータをコピー
　　　↓
新規に作成した表の列幅をデータ長に合わせる
　　　↓
新規に作成した表のタイトルに色をつける
　　　↓
新規に作成した表を社員番号順にソート
　　　↓
新規ファイルを作成元ファイルがあるフォルダに保存

以上流れで作成したマクロが以下で紹介するサンプルコードになります。

サンプルコード　　　アプリの作成手順はこちら

「xPath = UrlToLocal(.Path) & “\"」のUrlToLocal関数の説明については以下リンク先を参照ください。
　https://scodebank.com/?p=696

Option Explicit '変数の宣言を強制する

Sub 別ファイル作成()

  '変数の定義
   Dim Wb1 As Worksheet, Wb2 As Workbook '作成元BOOK、作成先BOOK
   Dim Sh1 As Worksheet                  '作成元シート
   Dim Sh2 As Worksheet                  '作成先シート
   Dim FileNam As String                 '作成ファイル名
   Dim xPath As String                   '作成先パス
   Dim start As Long                     '作成元カウンター
   Dim i As Integer                      '作成先カウンター

  'ワークシートSheet1を変数Sh1に格納
   Set Sh1 = ThisWorkbook.Worksheets("Sheet1")
    
  '作成元データの開始行(4行目)を指定
   start = 4
    
   Set Wb1 = ActiveSheet  '作成元シートをActiveSheetにセット
      
  'UrlToLocal関数を使って出力先のパスを指定（作成元ファイルがあるフォルダを指定）
   With ActiveWorkbook
     xPath = UrlToLocal(.Path) & "\"
   End With

  '出力ファイル名を指定
  'FileNam = xPath & strDate & "_別表.xlsx"

   FileNam = xPath & "別表.xlsx"
    
   Set Wb2 = Workbooks.Add          '新規ブック作成
   Wb2.Sheets(1).Name = "別表"      '新規ブックのシート名を指定
   Set Sh2 = Wb2.Worksheets("別表") '新規ブックのシートを変数に格納
        
    
   '新規ブックの最初の貼り付け位置を指定（2行目から貼り付ける）
    i = 2
    
   '社員番号が空欄の位置までループ
    Do While Sh1.Cells(start, 2) <> ""

     'データコピー
      Sh2.Cells(i, 2) = Sh1.Cells(start, 2) '社員番号
      Sh2.Cells(i, 3) = Sh1.Cells(start, 3) '名前
      Sh2.Cells(i, 4) = Sh1.Cells(start, 7) '通勤手当

      i = i + 1            'コピー先の行を一つ下にずらす。
      start = start + 1    'コピー元の行を一つ下にずらす。
    
    Loop
 

   'コピー先の列幅をデータ長に合わせる
    Wb2.Worksheets("別表").Range("B:D").Columns.AutoFit

   '表のタイトルに色をつける
    Wb2.Worksheets("別表").Range("B2:D2").Interior.Color = RGB(255, 242, 204)
     
   'データを社員番号順にソート
    Wb2.Worksheets("別表").Range("B3:D" & i).Sort Key1:=Range("D3"), Order1:=xlDescending '降順

   '作成したファイルを同一フォルダに保存して閉じる
    Wb2.SaveAs Filename:=FileNam
    Wb2.Close
     
   '作成したブックを解放
    Set Wb2 = Nothing
     
   '作成完了メッセージを表示
    MsgBox "別表の作成が完了しました。"

End Sub

'--------- 以下「UrlToLocal」関数 ------------------------------------

Public Function UrlToLocal(ByRef Url As String) As String

  'OneDrive環境変数を格納する変数の定義
   Dim OneDrive As String

  'OneDrive環境変数の取得
   OneDrive = Environ("OneDrive")

  '「https://･･･････/Documents」までの文字数を格納する変数の定義
   Dim CharPosi As String

  ' ＵＲＬからローカルパスを作成する
   If Url Like "https://*" Then 'OneDriveのパスかどうかの判定
           
    '「https://･･･････/Documents」までの文字数を取得
      CharPosi = InStr(1, Url, "/Documents") + 10
      
    'ローカルパス作成
      Url = OneDrive & Replace(Mid(Url, CharPosi), "/", Application.PathSeparator)
    
   Else
    
    'OneDriveのパス以外だったらカレントドライブ指定
     ChDrive Left(Url, 1)
     
   End If

 '作成したローカルパスを返す
  UrlToLocal = Url

End Function