VBA_CSV出力・シート値検索等々、書いてみました。

他部より相談。新しい勤怠システムを導入予定なものの、エクセルをCSVにして取り込む必要があり、そのVBAを書いてみました。

ネットでTipsを漁ってはコーディング。概ねできました。

Sub CSV化()

    Dim i As Long, B As Variant

    Dim tbl As Variant

    Dim ret As String

    Dim FindCell As Range

    Dim t As Long

    Dim xlLastRow As Long

    Dim LastRow As Long

    Dim n As Long

    Dim syainNum As String

    Dim syainNumCopy As String

    Dim str As String

    Dim monthDay As String

           

    B = Worksheets("①部署掲示用（管理表)").Range("A1:AJ20000")

    tbl = Worksheets("コード表").Range("A1:N200")

     

    '初期化

    i = 2 '2行目から値をセットするため

    t = 0

    n = 0

   

    Worksheets("②CSV取込用").Cells.Clear

    Worksheets("②CSV取込用").Cells(1, 1).Value = "*社員コード"

    Worksheets("②CSV取込用").Cells(1, 2).Value = "*勤務日YYYYMMDD"

    Worksheets("②CSV取込用").Cells(1, 3).Value = "パターンコード"

    Worksheets("②CSV取込用").Cells(1, 4).Value = "休暇区分"

    Worksheets("②CSV取込用").Cells(1, 5).Value = "振休季節休区分"

    Worksheets("②CSV取込用").Cells(1, 6).Value = "申請:開始時刻"

    Worksheets("②CSV取込用").Cells(1, 7).Value = "申請:終了時刻"

       

    '社員番号検索

    For t = 8 To 500

   

      '社員番号が空白の場合はループExit

      If Len(B(t, 1)) = 0 Then

         Exit For

      End If

      syainNum = B(t, 1)

           

      If syainNum <> syainNumCopy Then

        syainNumCopy = syainNum

        '日付（日付は空欄または年間カレンダー日数まで）×5回ループ処理

        '日付分各種値セット

        For n = 4 To 34

       

         '日付が空白の場合はループExit

         If Len(B(4, n)) = 0 Then

            Exit For

         End If

     

         'セルを文字列型にセット

         Worksheets("②CSV取込用").Cells(i, 1).NumberFormatLocal = "@"

         '社員番号セット

         Worksheets("②CSV取込用").Cells(i, 1).Value = syainNum

         '日付セット

         monthDay = Replace(B(5, 2) & B(4, n), "/01", "")

         Worksheets("②CSV取込用").Cells(i, 2).Value = Replace(monthDay, "/", "")

             

             

         '勤怠区分　勤怠コード一覧から一致するものを取得

         'Debug.Print (B(t + 1, n))

         Set FindCell = Worksheets("コード表").Range("A1:N200").Cells.Find(B(t + 1, n))

         Worksheets("②CSV取込用").Cells(i, 3).Value = Worksheets("コード表").Cells(FindCell.row, 6).Value '"パターンコード"

       

         '休暇区分　休暇コード一覧から取得

       

         Set FindCell = Worksheets("コード表").Range("A1:N200").Cells.Find(B(t + 4, n))

         Worksheets("②CSV取込用").Cells(i, 4).Value = Worksheets("コード表").Cells(FindCell.row, 10).Value '"休暇区分"

       

       

         '振出区分　空欄だったらNext処理　振出振休コード一覧から取得

         'Worksheets("②CSV取込用").Cells(i, 5).Value = B(t, n)    '"振休季節休区分"

       

         '振出区分　空欄だったらNext処理　振出振休コード一覧から取得

         Set FindCell = Worksheets("コード表").Range("A1:N200").Cells.Find(B(t, n))

         Worksheets("②CSV取込用").Cells(i, 5).Value = Worksheets("コード表").Cells(FindCell.row, 14).Value

             

         'セルを文字列型にセット

         Worksheets("②CSV取込用").Cells(i, 6).NumberFormatLocal = "@"

         '"申請:開始時刻"

         Worksheets("②CSV取込用").Cells(i, 6).Value = B(t + 2, n)

       

        'セルを文字列型にセット

         Worksheets("②CSV取込用").Cells(i, 7).NumberFormatLocal = "@"

         '"申請:終了時刻"

         Worksheets("②CSV取込用").Cells(i, 7).Value = B(t + 3, n)

                                   

         i = i + 1

     

        Next n

     

      End If

     

    Next t

   

     Worksheets("②CSV取込用").Activate

     CSV_Write

   

End Sub

Function CSV_Write()

    Dim FileType, Prompt As String

    Dim FileNamePath As Variant

    Dim StartRow, StartColumn, Max_Row, Max_Column As Integer

    Dim Rowcnt, Columncnt As Integer

    Dim UsedCell As Range

   

    Dim ch1 As Long

   

    FileType = "CSV ﾌｧｲﾙ (*.csv),*.csv"

    Prompt = "保存するファイルの名前を付けてください"

    '保存するファイルのパスを取得します

    FileNamePath = SaveFileNamePath(FileType, Prompt)

    If FileNamePath = False Then    'キャンセルボタンが押された

        End

    End If

       

    '空いているファイル番号を取得します

    ch1 = FreeFile

    'FileNamePath のファイルをオープンします

    Open FileNamePath For Output As #ch1

   

    '使用しているセルの取得

    Set UsedCell = ActiveSheet.UsedRange

   

    StartRow = UsedCell.Cells(1).row

    StartColumn = UsedCell.Cells(1).Column

    Max_Row = UsedCell.Cells(UsedCell.Count).row

    Max_Column = UsedCell.Cells(UsedCell.Count).Column

   

   

    For Rowcnt = StartRow To Max_Row

        For Columncnt = StartColumn To Max_Column - 1

            '改行を挿入しないで書き出す ; を最後に付ける

            Write #ch1, Cells(Rowcnt, Columncnt);

            'Print #ch1, Cells(Rowcnt, Columncnt);

        Next

        '改行を挿入する

        Write #ch1, Cells(Rowcnt, Max_Column)

        'Print #ch1, Cells(Rowcnt, Max_Column)

    Next

               

       

    'ファイルを閉じます

    Close #ch1

End Function

Function SaveFileNamePath(FileType, Prompt) As Variant

  SaveFileNamePath = Application.GetSaveAsFilename _

                                  (ActiveSheet.Name, FileType, , Prompt)

End Function