Sub 文字列生成例()
    Dim xx() As String, s As String
    Dim i As Long, j As Long, o As Long
    Dim r As Range
    o = Range("v1").Column - Range("e1").Column '作業者の責任者からのオフセット
    With Worksheets("Sheet1")
        For Each r In .Range("e2", .Cells(.Rows.Count, "e").End(xlUp))
            ReDim xx(0 To 10)
            j = 0
            xx(0) = r.Value & "(" & r.Offset(, 1).Value & ")"   '責任者名前（部署）
            For i = 1 - 1 To 10 - 1                             '作業者１〜作業者１０名前（部署）
                If r.Offset(, o + i * 2).Value <> "" Then   '空白列はskip
                    j = j + 1
                    xx(j) = r.Offset(, o + i * 2).Value & "(" & r.Offset(, o + i * 2 + 1).Value & ")"
                End If
            Next
            ReDim Preserve xx(0 To j)
            s = Join(xx, vbCrLf)
            Debug.Print s
        Next
    End With
End Sub


Win10 2016

kazuo様

お世話になります。お忙しい中，ご教示頂きましてありがとうございます。一つのデータの動作確認ができたのですが，これをルールさせようと次のようにしてみたのですが，同じものが繰り返されてしまいます。データが30人分あると仮定して，どのようにループさせればよろしいのでしょうか。申し訳ございませんが，ご教示頂けますでしょうか。

            ReDim Preserve xx(0 To j)
            s = Join(xx, vbCrLf)
            For k = 1 To 10
                Worksheets("Sheet2").Range("B" & k).Value = s
            Next k

別に良いのですが、7年くらいVBAを経験している慶次さんですよね。

Sub 回答例()
    Dim xx() As String, yy()
    Dim i As Long, j As Long, o As Long, k As Long
    Dim r As Range
    o = Range("v1").Column - Range("e1").Column '作業者の責任者からのオフセット
    With Worksheets("Sheet1")
        With .Range("e2", .Cells(.Rows.Count, "e").End(xlUp))
            ReDim yy(1 To .Rows.Count, 0)
            For Each r In .Cells
                ReDim xx(0 To 10)
                j = 0
                xx(0) = r.Value & "(" & r.Offset(, 1).Value & ")"   '責任者名前（部署）
                For i = 1 - 1 To 10 - 1                             '作業者１〜作業者１０名前（部署）
                    If r.Offset(, o + i * 2).Value <> "" Then   '空白列はskip
                        j = j + 1
                        xx(j) = r.Offset(, o + i * 2).Value & "(" & r.Offset(, o + i * 2 + 1).Value & ")"
                    End If
                Next
                ReDim Preserve xx(0 To j)
                k = k + 1
                yy(k, 0) = Join(xx, vbCrLf)
            Next
        End With
    End With
    Worksheets("Sheet2").Range("b1").Resize(UBound(yy)).Value = yy
End Sub

kazuo様

お礼のお返事が大変遅くなりましたことをお詫び申し上げます。ご指摘の件ですが，仕事でVBAでやりたいなと思ったときに少し勉強しながらやっている程度でありまして，kazuo様やここで回答される方のような洗練された，かっこいいコードを書く能力は微塵もございません。いまだに配列は苦手です。今回のkazuo様のコードも理解できるところと理解できないところがあります。例えば，以下のようなところです。なぜわざわざ-1をするのか（つまり0 to 9ではいけないのか）など...

 For i = 1 - 1 To 10 - 1    

ご不快な思いをさせてしまうことは承知でお尋ねした次第です。

私が希望している動作の確認ができました。kazuo様，ありがとうございました。

お世話になっております。

kazuo様に作っていただきました下記のコードですが，もう一つ行わなければならない内容が出て参りました。前回は，行毎に一つのデータとして一つのセルに入れていただいたのですが，今回は責任者および作業者の名前だけをすべて異なるセルに入れたいのです（部署抜きです）。

【前回】
責任者（部署）
作業者1（部署）
作業者2（部署）

これが一つのセルに収まっております。

【今回】
責任者
作業者1
作業者2

これがそれぞれのセルに収まります。
責任者がB2
作業者1がB3
作業者2がB4

そしてつぎの行データが
B5
B6
B7
とつづきます。つまり，全人のデータが縦に繋がり，それぞれが一つのセルに収まると言うことです。

私のレベルはkazuo様の洗練されたコードを改変するようなレベルからはほど遠く，失礼であることは理解しておりますが，ぜひお力を貸していただけませんでしょうか。

Sub 回答例()
    Dim xx() As String, yy()
    Dim i As Long, j As Long, o As Long, k As Long
    Dim r As Range
    o = Range("v1").Column - Range("e1").Column '作業者の責任者からのオフセット
    With Worksheets("Sheet1")
        With .Range("e2", .Cells(.Rows.Count, "e").End(xlUp))
            ReDim yy(1 To .Rows.Count, 0)
            For Each r In .Cells
                ReDim xx(0 To 10)
                j = 0
                xx(0) = r.Value & "(" & r.Offset(, 1).Value & ")"   '責任者名前（部署）
                For i = 1 - 1 To 10 - 1                             '作業者１〜作業者１０名前（部署）
                    If r.Offset(, o + i * 2).Value <> "" Then   '空白列はskip
                        j = j + 1
                        xx(j) = r.Offset(, o + i * 2).Value & "(" & r.Offset(, o + i * 2 + 1).Value & ")"
                    End If
                Next
                ReDim Preserve xx(0 To j)
                k = k + 1
                yy(k, 0) = Join(xx, vbCrLf)
            Next
        End With
    End With
    Worksheets("Sheet2").Range("b1").Resize(UBound(yy)).Value = yy
End Sub

これでいいのかしらん？

Sub 回答2例()
    Dim xx() As String, yy()
    Dim i As Long, j As Long, o As Long, k As Long
    Dim r As Range
    o = Range("v1").Column - Range("e1").Column '作業者の責任者からのオフセット
    With Worksheets("Sheet1")
        With .Range("e2", .Cells(.Rows.Count, "e").End(xlUp))
            ReDim yy(1 To .Rows.Count * 11, 0)
            For Each r In .Cells
                j = j + 1
                yy(j, 0) = r.Value              '責任者名前
                For i = 1 - 1 To 10 - 1        '作業者１〜作業者１０名前
                    If r.Offset(, o + i * 2).Value <> "" Then   '空白列はskip
                        j = j + 1
                        yy(j, 0) = r.Offset(, o + i * 2).Value
                    End If
                Next
            Next
        End With
    End With
    Worksheets("Sheet2").Range("b2").Resize(UBound(yy)).Value = yy
End Sub