| |
あー・・1行目のタイトルだけは、必ず転記するわけでしたか。
それなら
Sub Data_Align()
Dim Sh As Worksheet
Dim VAry As Variant, SAry As Variant
Dim i As Long, SR As Long, ER As Long
Dim Ans As Long, x As Long, y As Long
On Error Resume Next
Set Sh = Worksheets("Sheet2")
If Err.Number > 0 Then
Set Sh = Worksheets.Add(After:=Sheets("Sheet1"))
AtiveSheet.Name = "Sheet2": Err.Clear
End If
On Error GoTo 0
Ans = MsgBox("2行目を副タイトル行としますか", 36)
If Ans = 6 Then
SR = 3
Else
SR = 2
End If
With Sheets("Sheet1")
With .Range("A1").CurrentRegion
x = .Columns.Count: ER = .Rows.Count
End With
If .Columns(x).Find("*,*", , xlValues) Is Nothing Then
MsgBox x & " 列にカンマ区切りのデータがありません", 48
Exit Sub
End If
For i = SR To ER
If Len(.Cells(i, x).Value) < 2 Then
VAry = .Cells(i, 1).Resize(, x).Value
Sh.Range("A65536").End(xlUp).Offset(1) _
.Resize(, x).Value = VAry
Else
SAry = Split(.Cells(i, x).Value, ",")
y = UBound(SAry) + 1
VAry = .Cells(i, 1).Resize(, x - 1).Value
With Sh.Range("A65536").End(xlUp)
.Offset(1).Resize(y, x - 1).Value = VAry
.Offset(1, x - 1).Resize(y).Value = _
WorksheetFunction.Transpose(SAry)
End With
Erase SAry
End If
Next i
Sh.Range("A1")Resize(, x).Value = _
.Range("A1").Resize(, x).Value
End With
Sh.Activate: Set Sh = Nothing
End Sub
|
|
Kein
- 04/9/4(土) 22:56 -
