エクセルのデータを別ファイルに分割する。

項目ごとに分割して別ファイルに出力する。

▼会社の入り口に設置されたタイムレコーダーでは、押しわすれなどで発生する全社員の出勤不明時間データが、CSVファイルで出力されます。

この出勤不明データを事業部ごとに分割して別々のファイルで出力する場合のマクロを作成しました。

上のデータを事業部ごとに次のようなファイルを作成します。

１．財経部の社員の出勤時間不明データ（財経部.xls）

２．営業部の社員の出勤時間不明データ（営業部.xls）

ファイル作成サブルーチンは下記のようなコードで作成しました。

ExcelTool.vb

'2015/09/04 --------------------------------------------------*
Private Sub s_ファイル作成実行(qCategory As String)
  Dim wFileID   As String
  Dim wBookName As String
  '
  Dim wRow      As String
  Dim wAbc      As String
  Dim wSaveName As String  '保存名
  Dim wRange    As String
  Dim wCntRow   As Integer
  Dim wCopyRow  As String
  Dim wPastRow  As String
  Dim wItem     As String
  Dim wNo   As Integer
  Dim wFL   As Integer
  Dim wBook As String
  
  wBook = fnPickFile(gMyBook)
  
  'ワークブック名を作成
  wAbc = Me.cbo列.Text
  wRow = Me.cbo行.Text
  
  wSaveName = Trim(qCategory)
  wSaveName = Replace(wSaveName, " ", "")
  wSaveName = Replace(wSaveName, "　", "")
  
  wFileID = Format(Date, "yyyymmdd") & Format(Time, "hhmmss")
  '2015/09/11 先頭日付を無くした
  wBookName = wSaveName & ".xlsx"
  
  '新規ファイルを作る
  Workbooks.Add
  'ワークブックを別名で保存
  ActiveWorkbook.SaveAs FileName:=wBookName
  'ヘッダコピー
  wRange = "1:" & wRow
  Workbooks(wBook).Worksheets(1).Rows(wRange).Copy
  Workbooks(wBookName).Worksheets(1).Rows(wRange).Select
  Workbooks(wBookName).Worksheets(1).Rows(wRange).PasteSpecial Paste:=xlPasteAll
  Workbooks(wBookName).Worksheets(1).Rows(wRange).PasteSpecial Paste:=xlPasteColumnWidths
  
  wCntRow = Val(wRow) + 1
  wNo = wCntRow
  wFL = 0
  Do
    wRange = Replace(wAbc, "列", "") & Trim(Str(wCntRow))
    wItem = Workbooks(wBook).Worksheets(1).Range(wRange)
    
    If qCategory = wItem Then
      wFL = 1
      wCopyRow = Trim(Str(wCntRow))
      wPastRow = Trim(Str(wNo))
      
      Workbooks(wBook).Worksheets(1).Rows(wCopyRow).Copy _
      Workbooks(wBookName).Worksheets(1).Rows(wPastRow)

      wNo = wNo + 1
    Else
      If wFL = 1 Then Exit Do
    End If
    
    wCntRow = wCntRow + 1
    If wCntRow > 1000 Then Exit Do
  Loop
  
  Workbooks(wBookName).Worksheets(1).Range("A1").Select
  Workbooks(wBookName).Save
  Workbooks(wBookName).Close SaveChanges:=False
End Sub

プログラムを起動したときのメニュー画面

サンプルデータを作成して、汎用的に実行できるように作成しました。

プログラムダウンロード

下のURLのページからダウンロードすることが出来ます。

▼ダウンロード
https://www.excel-access-japan.com/excel-tool/

---

AccessとExcelを連携してクラウドシステムを作成する

データベースをAzure SQL にセットして、AccessやExcelのプログラムから データベースを遠隔地間で共有するシステムを公開しています。

http://access-cloud.hatenablog.com/entry/database