セルの値出力（数式を除く）

/

Option Explicit

‘————————————————–
‘プロシージャの概要:
‘処理名:outputCellValues
‘概要:全シートのセル入力値を「セル入力値」シートに書き出す（数式は除外）
‘————————————————–
Public Sub outputCellValues()

'定数定義
Const C_TARGET_SHEET_NAME As String = "セル入力値"
Const C_OUTPUT_START_ROW As Long = 2
Const C_COL_SHEET_NAME As Long = 1
Const C_COL_CELL_ADDRESS As Long = 2
Const C_COL_CELL_VALUE As Long = 3
Const C_OUTPUT_COL_COUNT As Long = 3

Dim wsTarget As Worksheet
Dim wsLoop As Worksheet
Dim rngUsed As Range
Dim rngCell As Range
Dim lngCellCount As Long
Dim lngIndex As Long
Dim arrOutput() As Variant
Dim binScreenUpdating As Boolean
Dim lngCalculation As Long
Dim binEnableEvents As Boolean

'現在の設定を退避
binScreenUpdating = Application.ScreenUpdating
lngCalculation = Application.Calculation
binEnableEvents = Application.EnableEvents

'高速化設定
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

On Error GoTo ERROR_HANDLER

'出力先シートの設定
Set wsTarget = ThisWorkbook.Worksheets(C_TARGET_SHEET_NAME)

'既存データの削除（出力開始行以降）
If wsTarget.Cells(wsTarget.Rows.Count, C_COL_SHEET_NAME).End(xlUp).Row >= C_OUTPUT_START_ROW Then
    wsTarget.Range(wsTarget.Cells(C_OUTPUT_START_ROW, C_COL_SHEET_NAME), _
                   wsTarget.Cells(wsTarget.Cells(wsTarget.Rows.Count, C_COL_SHEET_NAME).End(xlUp).Row, C_COL_CELL_VALUE)).ClearContents
End If

'対象セル数のカウント（1回目のループ）
lngCellCount = 0

For Each wsLoop In ThisWorkbook.Worksheets

    '出力先シート自身はスキップ
    If wsLoop.Name = wsTarget.Name Then GoTo CONTINUE_SHEET_COUNT

    '使用範囲の取得
    Set rngUsed = wsLoop.UsedRange

    '使用範囲内の各セルを走査
    For Each rngCell In rngUsed

        '空セルはスキップ
        If rngCell.Value = "" Then GoTo CONTINUE_CELL_COUNT

        '数式セルはスキップ
        If rngCell.HasFormula Then GoTo CONTINUE_CELL_COUNT

        'カウントアップ
        lngCellCount = lngCellCount + 1

CONTINUE_CELL_COUNT:
Next rngCell

CONTINUE_SHEET_COUNT:
Next wsLoop

'対象セルが存在しない場合は終了
If lngCellCount = 0 Then GoTo FINALLY

'配列の確保
ReDim arrOutput(1 To lngCellCount, 1 To C_OUTPUT_COL_COUNT)

'配列へのデータ格納（2回目のループ）
lngIndex = 0

For Each wsLoop In ThisWorkbook.Worksheets

    '出力先シート自身はスキップ
    If wsLoop.Name = wsTarget.Name Then GoTo CONTINUE_SHEET_OUTPUT

    '使用範囲の取得
    Set rngUsed = wsLoop.UsedRange

    '使用範囲内の各セルを走査
    For Each rngCell In rngUsed

        '空セルはスキップ
        If rngCell.Value = "" Then GoTo CONTINUE_CELL_OUTPUT

        '数式セルはスキップ
        If rngCell.HasFormula Then GoTo CONTINUE_CELL_OUTPUT

        'インデックスを進める
        lngIndex = lngIndex + 1

        '配列にデータを格納
        arrOutput(lngIndex, C_COL_SHEET_NAME) = wsLoop.Name
        arrOutput(lngIndex, C_COL_CELL_ADDRESS) = rngCell.Address(False, False)
        arrOutput(lngIndex, C_COL_CELL_VALUE) = rngCell.Value

CONTINUE_CELL_OUTPUT:
Next rngCell

CONTINUE_SHEET_OUTPUT:
Next wsLoop

'配列を一括で貼り付け
wsTarget.Cells(C_OUTPUT_START_ROW, C_COL_SHEET_NAME).Resize(lngCellCount, C_OUTPUT_COL_COUNT).Value = arrOutput

FINALLY:
‘後処理
Erase arrOutput
Set rngCell = Nothing
Set rngUsed = Nothing
Set wsLoop = Nothing
Set wsTarget = Nothing

'設定を復元
Application.ScreenUpdating = binScreenUpdating
Application.Calculation = lngCalculation
Application.EnableEvents = binEnableEvents

Exit Sub

ERROR_HANDLER:
‘エラー発生時も設定を復元
Application.ScreenUpdating = binScreenUpdating
Application.Calculation = lngCalculation
Application.EnableEvents = binEnableEvents

MsgBox "エラーが発生しました。" & vbCrLf & _
       "エラー番号：" & Err.Number & vbCrLf & _
       "エラー内容：" & Err.Description, vbCritical, "エラー"

End Sub