VBA

VBA使い方

1. ExcelでAlt + F11 を押してVBAエディタを開く
2. 挿入>標準モジュールから新しいモジュールを作成
3. コードを貼り付ける
4. F5 またはExcel側のマクロ実行で処理開始

セルの値を比較して赤字にする

Sub CompareAndHighlightDifferences()
    Dim lastRow As Long
    Dim i As Long
    Dim valA As String, valB As String
    Dim j As Long

    lastRow = Cells(Rows.Count, "B").End(xlUp).Row

    For i = 1 To lastRow
    ' Cells(i, "A")のAを変えると列を変えれる
        valA = Trim(Cells(i, "A").Value) 
        valB = Trim(Cells(i, "B").Value)

        ' 初期状態に戻す（黒にリセット）
        With Cells(i, "B")
            .Font.Color = RGB(0, 0, 0)
            .Characters.Font.Color = RGB(0, 0, 0)
        End With

        If valA <> "" And valB = "" Then
            ' A列に文字あり、B列が空白 → スキップ
            GoTo ContinueLoop

        ElseIf valA = "" And valB <> "" Then
            ' A列が空白、B列に文字 → B列全部赤字
            With Cells(i, "B").Characters(1, Len(valB)).Font
                .Color = RGB(255, 0, 0)
            End With

        ElseIf valA <> "" And valB <> "" Then
            ' 両方に文字がある → 1文字ずつ比較
            For j = 1 To Len(valB)
                If Mid(valA, j, 1) <> Mid(valB, j, 1) Then
                    If j <= Len(valB) Then
                        Cells(i, "B").Characters(j, 1).Font.Color = RGB(255, 0, 0)
                    End If
                End If
            Next j
        End If

ContinueLoop:
    Next i
End Sub

指定したフォルダ内の複数ブックから特定シートの特定列の値をまとめて取り出す：使い方

• resultシートを用意
  • B1: 参照フォルダ（例: C:\work\books）
  • B2: 参照するシート名（例: Sheet1）
  • B3: 列アドレスを区切りで列挙（例: A,B,D／.区切りでもOK）
• dataを用意
• シートは実行時に全消去してヘッダから書き直す
• *.xls*（xls/xlsx/xlsm等）が対象

指定したフォルダ内の複数ブックから、特定シートの特定列の値をまとめて取り出す

Option Explicit

Sub GetColumnValuesFromResultSheet()
    Dim folderPath As String
    Dim sheetName As String
    Dim rawCols As String
    Dim columnAddresses As Variant
    
    Dim resultWb As Workbook
    Dim results As Worksheet
    Dim dataWs As Worksheet
    
    Dim fileName As String
    Dim wb As Workbook
    Dim ws As Worksheet
    
    Dim cellValue As Variant
    Dim i As Long, j As Long
    Dim dataRow As Long
    Dim columnAddress As String
    Dim lastRow As Long
    Dim dataCol As Long
    Dim startRow As Long
    Dim lastCell As Range
    Dim maxRowsThisFile As Long
    
    Application.ScreenUpdating = False
    
    Set resultWb = ThisWorkbook
    Set results = resultWb.Worksheets("result")
    Set dataWs = resultWb.Worksheets("data")
    
    ' パラメータ取得
    folderPath = Trim$(CStr(results.Range("B1").Value))
    sheetName = Trim$(CStr(results.Range("B2").Value))
    rawCols = Trim$(CStr(results.Range("B3").Value))
    
    ' 列指定の区切りを吸収（カンマ or ドット、全角カンマも対応）
    rawCols = Replace(rawCols, "、", ",")
    rawCols = Replace(rawCols, " ", "")
    If InStr(rawCols, ",") > 0 Then
        columnAddresses = Split(rawCols, ",")
    ElseIf InStr(rawCols, ".") > 0 Then
        columnAddresses = Split(rawCols, ".")
    Else
        ReDim columnAddresses(0)
        columnAddresses(0) = rawCols
    End If
    
    If Len(folderPath) = 0 Or Len(sheetName) = 0 Or Len(rawCols) = 0 Then
        MsgBox "resultシートの B1(フォルダ), B2(シート名), B3(列アドレス) を設定してください。", vbExclamation
        GoTo TidyUp
    End If
    
    ' 末尾の区切り（\ または /）を補正
    If Right$(folderPath, 1) <> "\" And Right$(folderPath, 1) <> "/" Then
        folderPath = folderPath & "\"
    End If
    
    ' dataシート初期化とヘッダ
    dataWs.Cells.ClearContents
    dataWs.Cells(1, 1).Value = "File Name"
    dataWs.Cells(1, 2).Value = "Sheet Name"
    dataRow = 2
    
    ' フォルダ内のExcelを走査（xls/xlsx/xlsm等）
    fileName = Dir(folderPath & "*.xls*")
    Do While Len(fileName) > 0
        On Error Resume Next
        Set wb = Workbooks.Open(folderPath & fileName, ReadOnly:=True)
        If wb Is Nothing Then
            Debug.Print "Error opening file: " & fileName
            On Error GoTo 0
            GoTo NextFile
        End If
        
        Set ws = Nothing
        Set ws = wb.Worksheets(sheetName)
        If ws Is Nothing Then
            Debug.Print "Sheet not found: " & sheetName & " in file: " & fileName
            wb.Close SaveChanges:=False
            On Error GoTo 0
            GoTo NextFile
        End If
        On Error GoTo 0
        
        ' このファイルの書き出し開始位置と列の初期化
        dataCol = 3
        startRow = dataRow
        maxRowsThisFile = 0
        
        ' 指定された各列を処理
        For i = LBound(columnAddresses) To UBound(columnAddresses)
            columnAddress = Trim$(CStr(columnAddresses(i)))
            If columnAddress = "" Then GoTo NextColumn
            
            ' もし "A:A" のような表記なら先頭側だけ使う
            If InStr(columnAddress, ":") > 0 Then
                columnAddress = Split(columnAddress, ":")(0)
            End If
            
            ' 最終行の特定（値/式のいずれかが入っている最後の行）
            lastRow = 0
            On Error Resume Next
            Set lastCell = ws.Columns(columnAddress).Find(What:="*", LookIn:=xlFormulas, _
                              LookAt:=xlPart, SearchOrder:=xlByRows, _
                              SearchDirection:=xlPrevious, MatchCase:=False)
            On Error GoTo 0
            If Not lastCell Is Nothing Then lastRow = lastCell.Row
            
            ' 見出し（列ごとに2列確保：番地／値）
            dataWs.Cells(1, dataCol).Value = "Cell Address (" & columnAddress & ")"
            dataWs.Cells(1, dataCol + 1).Value = "Cell Value (" & columnAddress & ")"
            
            ' この列の書き出し
            dataRow = startRow
            If lastRow > maxRowsThisFile Then maxRowsThisFile = lastRow
            
            For j = 1 To lastRow
                cellValue = Empty
                On Error Resume Next
                cellValue = ws.Range(columnAddress & j).Value   ' 例: "A" & 5 -> "A5"
                If Err.Number <> 0 Then
                    Debug.Print "Error reading cell: " & columnAddress & j & _
                                " in sheet: " & sheetName & " in file: " & fileName
                    Err.Clear
                End If
                On Error GoTo 0
                
                dataWs.Cells(dataRow, 1).Value = fileName
                dataWs.Cells(dataRow, 2).Value = sheetName
                dataWs.Cells(dataRow, dataCol).Value = columnAddress & j
                dataWs.Cells(dataRow, dataCol + 1).Value = cellValue
                dataRow = dataRow + 1
            Next j
            
            ' 次の列ペアへ
            dataCol = dataCol + 2
            
NextColumn:
        Next i
        
        ' 次のファイルは1行空けて開始（最大行数分+1）
        If maxRowsThisFile > 0 Then
            dataRow = startRow + maxRowsThisFile + 1
        Else
            dataRow = startRow + 1
        End If
        
        wb.Close SaveChanges:=False
        
NextFile:
        fileName = Dir()
    Loop
    
TidyUp:
    Application.ScreenUpdating = True
End Sub

dataシート出力イメージ

File Name	Sheet Name	Cell Address (A)	Cell Value (A)	Cell Address (C)	Cell Value (C)
book1.xlsx	Sheet1	A1	ID001	C1	Tokyo
book1.xlsx	Sheet1	A2	ID002	C2	Osaka
…	…	…	…	…	…
book2.xlsx	Sheet1	A1	ID101	C1	Nagoya
…	…	…	…	…	…