-18

とりあえずシートに分けるマクロは作ってみました。

まず、各シートは4行目からデータが入っているとして、

図のようにSheet1の1行目の作業１とか作業２というのはマージされたセルとします。

ここから作業の数を数えて自動的に作業１とか作業２という名前のシートを作りデータをコピーします。

コピーする列は図ならば作業１がＢＬ列～ＥＯ列までという感じです。

＞★Sheet２,３,４のデータの判定（列AV）を変更した場合、データの移動が行われます。

この機能は実装しませんでした。この機能を実装することにより、かなりのオーバーヘッドが発生し

処理が重くなると思われます。面倒でもマクロを一回一回実行させたほうがいいと思われます。

Option Explicit

Type Sagyou
    name As String
    start As Integer
    end As Integer
    count As Long
End Type

Sub SheetWake()
    Application.ScreenUpdating = False
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim s() As Sagyou
    Dim f As Boolean
    ReDim s(0)
    Dim sh As Worksheet
    Dim lastRow As Long
    Dim r As Range
    
    '作業データの取得
    j = 1
    For i = 63 To 255
        If Sheet1.Cells(1, i).MergeCells Then
            If Not f Then
                ReDim Preserve s(UBound(s) + 1)
                s(UBound(s)).name = Sheet1.Cells(1, i).Value
                s(UBound(s)).start = i
                f = True
            End If
            s(UBound(s)).end = i
        Else
            f = False
        End If
    Next i
    
    'シートの追加
    For i = 1 To UBound(s)
        f = False
        For Each sh In Worksheets
            If sh.name = s(i).name Then
                Sheet1.Range(Cells(1, s(i).start), Cells(3, s(i).end)).Copy sh.Range("A1")
                f = True
                Exit For
            End If
        Next
        If Not f Then
            Set sh = Worksheets.Add
            sh.name = s(i).name
            Sheet1.Activate
            Sheet1.Range(Cells(1, s(i).start), Cells(3, s(i).end)).Copy sh.Range("A1")
        End If
    Next i
    
    '数式の除去
    For Each r In Sheet1.UsedRange
        If r.Row > 3 Then
            r.Value = r.Value
        End If
    Next
    
    'シートのクリア
    For Each sh In Worksheets
        If sh.name <> "Sheet1" Then
            sh.Rows("4:65536").ClearContents
        End If
    Next
    
    'データの移動
    lastRow = Sheet1.UsedRange.Rows(Sheet1.UsedRange.Rows.count).Row
    For i = 4 To lastRow
        f = False
        For j = 1 To UBound(s)
            If Sheet1.Cells(i, "AV").Value = s(j).name Then
                f = True
                Exit For
            End If
        Next
        If f Then
            Set sh = Worksheets(Sheet1.Cells(i, "AV").Value)
            sh.Cells(s(j).count + 4, 1).Value = s(j).name
            Sheet1.Cells(i, "AV").Formula = "=" & s(j).name & "!A" & s(j).count + 4
            For k = 1 To s(j).end - s(j).start
                sh.Cells(s(j).count + 4, k + 1).Value = Sheet1.Cells(i, s(j).start + k).Value
                Sheet1.Cells(i, s(j).start + k).Formula = "=" & s(j).name & "!" & sh.Cells(s(j).count + 4, k + 1).Address
            Next
            s(j).count = s(j).count + 1
        End If
    Next i
    Application.ScreenUpdating = True
End Sub