Option Explicit Sub abc() Dim a, i As Long, j As Long, m As Long a = [a1].CurrentRegion.Offset(1).Resize(, 2).Value ReDim b(1 To 10 ^ 5, 1 To 2) For i = 1 To UBound(a) - 1 For j = 1 To a(i, 2) m = m + 1 b(m, 1) = "号码" & m: b(m, 2) = a(i, 1) Next Next [d2].Resize(m, 2) = b End Sub