Sub Process6ASheet()
    Dim ws5A As Worksheet
    Dim ws6A As Worksheet
    Dim wsInput As Worksheet
    Dim writeRow As Integer
    Dim currentRow As Integer
    Dim baValue As String
    Dim bfValue As String
    Dim boValue As String
    Dim idName As String
    Dim av10Range As String
    Dim av11Range As String
    Dim av12Range As String
    Dim copyRange As Range
    Dim pasteRange As Range
    Dim rangeAddress As String
    Dim rangeParts As Variant
    Dim col2 As Integer, col4 As Integer
    Dim foundRow As Range
    Dim lastRow As Long
    
    ' ワークシートを取得
    On Error Resume Next
    Set ws5A = ThisWorkbook.Worksheets("5A_フロー")
    Set ws6A = ThisWorkbook.Worksheets("6A")
    Set wsInput = ThisWorkbook.Worksheets("★入力★授受物情報")
    On Error GoTo 0
    
    ' シートの存在確認
    If ws5A Is Nothing Then
        MsgBox "シート『5A_フロー』が見つかりません。", vbCritical
        Exit Sub
    End If
    If ws6A Is Nothing Then
        MsgBox "シート『6A』が見つかりません。", vbCritical
        Exit Sub
    End If
    If wsInput Is Nothing Then
        MsgBox "シート『★入力★授受物情報』が見つかりません。", vbCritical
        Exit Sub
    End If
    
    ' 6Aシートの参照範囲を取得
    av10Range = ws6A.Range("AV10").Value
    av11Range = ws6A.Range("AV11").Value
    av12Range = ws6A.Range("AV12").Value
    
    ' 範囲が空の場合はエラー
    If av10Range = "" Or av11Range = "" Or av12Range = "" Then
        MsgBox "AV10、AV11、AV12のいずれかが空です。", vbCritical
        Exit Sub
    End If
    
    ' 初期書き込み行数を16にセット
    writeRow = 16
    
    ' 5A_フローシートのBA列の最終行を取得
    lastRow = ws5A.Cells(ws5A.Rows.Count, 53).End(xlUp).Row ' BA列 = 53列目
    
    ' BA列を順次処理（21行目から開始）
    For currentRow = 21 To lastRow
        baValue = ws5A.Cells(currentRow, 53).Value ' BA列
        bfValue = ws5A.Cells(currentRow, 58).Value ' BF列
        boValue = ws5A.Cells(currentRow, 67).Value ' BO列
        
        ' BA列が空でない場合のみ処理
        If baValue <> "" Then
            ' AV10の範囲をコピーして書き込み行に貼り付け
            On Error Resume Next
            Set copyRange = ws6A.Range(av10Range)
            On Error GoTo 0
            
            If Not copyRange Is Nothing Then
                Set pasteRange = ws6A.Range(copyRange.Address).Offset(writeRow - copyRange.Row, 0)
                copyRange.Copy
                pasteRange.PasteSpecial xlPasteValues
                Application.CutCopyMode = False
                
                ' AV10範囲の2番目と4番目の列番号を取得
                rangeAddress = copyRange.Address(False, False)
                col2 = GetNthColumnFromRange(rangeAddress, 2)
                col4 = GetNthColumnFromRange(rangeAddress, 4)
                
                ' BA列とBF列の値を該当列位置に値貼り付け
                If col2 > 0 Then ws6A.Cells(writeRow, col2).Value = baValue
                If col4 > 0 Then ws6A.Cells(writeRow, col4).Value = bfValue
                
                ' 書き込み行を2行加算
                writeRow = writeRow + 2
            End If
            
            ' BO列が空白でない場合の処理
            If boValue <> "" Then
                ' BA列の値でID名を検索
                idName = ""
                Set foundRow = wsInput.Columns(9).Find(baValue, LookIn:=xlValues, LookAt:=xlWhole) ' I列 = 9列目
                If Not foundRow Is Nothing Then
                    idName = foundRow.Value
                End If
                
                ' AV11の範囲をコピーして書き込み行に貼り付け
                On Error Resume Next
                Set copyRange = ws6A.Range(av11Range)
                On Error GoTo 0
                
                If Not copyRange Is Nothing Then
                    Set pasteRange = ws6A.Range(copyRange.Address).Offset(writeRow - copyRange.Row, 0)
                    copyRange.Copy
                    pasteRange.PasteSpecial xlPasteValues
                    Application.CutCopyMode = False
                    
                    ' AV11範囲の2番目の列番号を取得
                    rangeAddress = copyRange.Address(False, False)
                    col2 = GetNthColumnFromRange(rangeAddress, 2)
                    
                    ' IDコード名を連結して元の列位置に貼り付け
                    If col2 > 0 Then
                        Dim currentValue As String
                        currentValue = ws6A.Cells(writeRow, col2).Value
                        If idName <> "" Then
                            ws6A.Cells(writeRow, col2).Value = currentValue & idName
                        Else
                            ws6A.Cells(writeRow, col2).Value = currentValue
                        End If
                    End If
                    
                    ' 書き込み行を2行加算
                    writeRow = writeRow + 2
                End If
                
                ' AV12の範囲をコピーして書き込み行に貼り付け
                On Error Resume Next
                Set copyRange = ws6A.Range(av12Range)
                On Error GoTo 0
                
                If Not copyRange Is Nothing Then
                    Set pasteRange = ws6A.Range(copyRange.Address).Offset(writeRow - copyRange.Row, 0)
                    copyRange.Copy
                    pasteRange.PasteSpecial xlPasteValues
                    Application.CutCopyMode = False
                    
                    ' 書き込み行を2行加算
                    writeRow = writeRow + 2
                End If
            End If
        End If
    Next currentRow
    
    MsgBox "処理が完了しました。", vbInformation
End Sub

' 範囲文字列からN番目の列番号を取得する関数
Private Function GetNthColumnFromRange(rangeAddr As String, n As Integer) As Integer
    Dim rangeParts As Variant
    Dim startCell As String
    Dim endCell As String
    Dim startCol As Integer
    Dim endCol As Integer
    Dim colCount As Integer
    
    GetNthColumnFromRange = 0
    
    ' 範囲が ":" を含む場合（例：A1:D1）
    If InStr(rangeAddr, ":") > 0 Then
        rangeParts = Split(rangeAddr, ":")
        startCell = rangeParts(0)
        endCell = rangeParts(1)
        
        ' 開始列と終了列を取得
        startCol = Range(startCell).Column
        endCol = Range(endCell).Column
        
        ' 列数をカウント
        colCount = endCol - startCol + 1
        
        ' N番目の列が存在する場合
        If n <= colCount Then
            GetNthColumnFromRange = startCol + n - 1
        End If
    Else
        ' 単一セルの場合
        If n = 1 Then
            GetNthColumnFromRange = Range(rangeAddr).Column
        End If
    End If
End Function