大佬帮帮忙，这些数据怎么提取出来

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, br, i&, j&, k&, p&, n&, s$, r&
   
    With Sheets(1).UsedRange
        ar = .Resize(.Rows.Count + 1)
    End With
    With [A1].CurrentRegion
        .Offset(1).Clear
        br = .Resize(UBound(ar))
        r = 1
    End With
    With CreateObject("VBScript.RegExp")
        .Pattern = "(Department: )(\d{4})"
        For i = 2 To UBound(ar) - 1
            If .test(ar(i, 1)) Then
                p = i + 3: s = .Execute(ar(i, 1))(0).submatches(1): n = 0
                For j = p To UBound(ar) - 1
                    If ar(j + 1, 2) = "" Then
                        For k = p To j
                            r = r + 1: n = n + 1
                            br(r, 1) = s & "-" & n
                            br(r, 2) = ar(k, 4)
                            br(r, 3) = ar(k, 2)
                        Next k
                        Exit For
                        i = j + 1
                    End If
                Next j
            End If
        Next i
    End With
   
    With [A1].Resize(r, 3)
         .Value = br
        .HorizontalAlignment = xlCenter
        .Borders.LineStyle = xlContinuous
        .Font.Bold = True
    End With

    Beep
End Sub

gwjkkkkk

请参考附件。。。