| |
えっと、通常は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
End With
Sh.Rows(1).Delete xlShiftUp: Sh.Activate
Set Sh = Nothing
End Sub
で、どうでしょーか ?
|
|
Kein
- 04/9/4(土) 22:50 -
