|
▼Kein さん:
こんばんは、しんです。
Keinさん修正コード
>
>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"))
> ActiveSheet.Name = "Sheet2": Err.Clear
> Else
> Sh.Cells.ClearContents
> 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
で副タイトル行のある4列の例題を作って変換処理テストを行った結果、正常に変換できることが確認できました。
行列処理を行って一気に変換という素晴らしい技に感激しました。胸につかえていた処理が一気にできるようになり、ほんとうにどうもありがとうございました。
|
|