VBA

Coding 

（作成：2022/05）

必要に迫られて作ってみたVBAファイルの紹介など。

数式を値に一括変換するExcel VBA

アイコン
アイコン

Digitalization.xlsm

1 ファイル 24.51 KB
ダウンロード

ゴリゴリの計算式&ファイル間参照使いまくりの資料なんかを作ったは良いけれど、最終的にはデータ化済の資料の提出が必要、そんな時に使えるVBA。

使い方

[カレントフォルダ]は作業中フォルダの共通部分のアドレスを入力。利便性の為のみの情報なので無くても良い。
[提出書類フォルダ]は作業中の資料保管フォルダを指定。
[保存先フォルダ]はデータ化したExcel資料を保管するフォルダを指定。
[マスタファイル]は作業中のファイル名を指定。最大10個まで。

項目入力後[変換]ボタンを押すと、以下のような動作でデータ化済資料が保存される。

  1. [マスタファイル]記載の順にExcel資料を展開
  2. 同順で全シートを全選択&コピー、値でペースト、保存先に同名保存
  3. 同順で全Excel資料を閉じる

ソース解説

ファイル中の[変換]ボタンに以下のVBAスクリプトを割り当てています。

Sub Digitalization()
    ' 定数定義
    Const SHEET_NAME As String = "convertSubmissions"
    Const MAX_FILES As Integer = 10
    Const COL_VAL As Integer = 2
    Const ROW_DIR As Integer = 3
    Const ROW_SAVEDIR As Integer = 4
    Const ROW_FILES As Integer = 5
    Const IGNORE_SHEET As String = "param"    ' デジタライズ時に削除するシート

    ' 変数定義
    Dim wb(10) As Workbook
    Dim svwb As Workbook
    Dim dir As String
    Dim svdir As String
    Dim fn As String
    Dim fname As String
    Dim svfname As String

    Dim fso As Object

    dir = ThisWorkbook.Worksheets(SHEET_NAME).Cells(ROW_DIR, COL_VAL).Value
    svdir = ThisWorkbook.Worksheets(SHEET_NAME).Cells(ROW_SAVEDIR, COL_VAL).Value

    ' 保存先フォルダの再作成(存在していたら削除)
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FolderExists(svdir) Then
        fso.DeleteFolder (svdir)
    End If
    MkDir (svdir)

    ' マスタファイルを順二オープン
    For i = 0 To MAX_FILES - 1
        r = i + ROW_FILES
        fn = ThisWorkbook.Worksheets(SHEET_NAME).Cells(r, COL_VAL).Value
        fname = dir + "\" + fn

        ' ファイル名が空ならforから抜ける
        If fn = "" Then
            Exit For
        End If

        Set wb(i) = openBooks(fname)
    Next

    ' 開いたファイルを順二デジタライズ
    For i = 0 To MAX_FILES - 1
        r = i + ROW_FILES
        fn = ThisWorkbook.Worksheets(SHEET_NAME).Cells(r, COL_VAL).Value
        svfname = svdir + "\" + fn

        ' ファイル名が空ならforから抜ける
        If fn = "" Then
            Exit For
        End If

        ' 数式→値コピー
        For s = 1 To wb(i).Sheets.Count
            If wb(i).Sheets(s).Name <> IGNORE_SHEET Then
                wb(i).Sheets(s).Visible = True
                wb(i).Sheets(s).Activate
                wb(i).Sheets(s).Cells.Select
                Selection.Copy
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            End If
        Next s

        ' デジタライズに不要なシートの削除
        Application.DisplayAlerts = False
        wb(i).Sheets(IGNORE_SHEET).Delete
        Application.DisplayAlerts = True

        ' 先頭シートのA1セルに移動
        wb(i).Sheets(1).Activate
        wb(i).Sheets(1).Range("A1").Select

        ' 保存フォルダに保存
        wb(i).SaveAs Filename:=svfname, FileFormat:=xlWorkbookDefault
    Next

    ' 開いていたマスタファイルをクローズ
    For i = 0 To UBound(wb) - 1
        If Not wb(i) Is Nothing Then
            Call wb(i).Close(SaveChanges:=False)
        End If
    Next
End Sub

' ファイルオープン関数
Function openBooks(ByRef fname As String) As Workbook
    Dim wb, chk As Workbook

    ' ファイル存在チェック
    If (dir(fname) = "") Then
        Debug.Print ("No exist: " + fname)
        Exit Function
    End If

    ' オープン済みかチェック
    For Each chk In Workbooks
        If chk.Name = fname Then
            Set openBooks = chk
            Exit Function
        End If
    Next

    Set openBooks = Workbooks.Open(fname, ReadOnly:=True)
End Function