|
Sub try()
Dim i As Long, k As Long, m As Long
Dim v, x
v = Worksheets("Sheet1").Range("A1").CurrentRegion
ReDim x(1 To (UBound(v, 1) - 1) * 3, 1 To (UBound(v, 2) - 1) / 2)
k = 1
For i = 2 To UBound(v, 1)
x(k, 1) = "顧客CD"
For m = 1 To UBound(v, 2)
If LenB(v(i, m)) > 0 Then
Select Case True
Case m = 1
x(k, 2) = v(i, m)
Case (m Mod 2) = 0
x(k + 1, m / 2) = v(i, m)
Case Else
x(k + 2, (m - 1) / 2) = v(i, m)
End Select
End If
Next
k = k + 3
Next
Worksheets("Sheet2").Range("A1").Resize(UBound(x, 1), UBound(x, 2)).Value = x
Erase v, x
End Sub
ご参考になれば幸いです。
|
|