| |
解決しちゃった様で？
Option Explicit
Public Sub DataConversion()
'項目列数を設定（項目1、項目2、項目3・・)
Const clngColumns As Long = 3
Dim i As Long
Dim lngRows As Long
Dim lngCount As Long
Dim rngList As Range
Dim vntID As Variant
Dim vntItems As Variant
Dim rngResult As Range
Dim vntResult As Variant
Dim lngRow As Long
Dim strProm As String
' Application.ScreenUpdating = False
'データのシートのList先頭セル位置を指定（ID項目の列見出しの位置）
Set rngList = Worksheets("Sheet1").Cells(1, "A")
With rngList
'データ行数を取得
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'ID列のデータを配列に取得
vntID = .Offset(1).Resize(lngRows).Value
End With
'出力シートの出力先頭セル位置を指定
Set rngResult = Worksheets("Sheet2").Cells(1, "A")
'出力シートの出力先頭に列見だしを出力
rngList.Resize(, clngColumns + 1).Copy Destination:=rngResult
'出力行位置の初期値
lngRow = 1
'データ行全てに就いて繰り返し
For i = 1 To lngRows
'IDを配列にカンマ区切りで分割
vntResult = Split(vntID(i, 1), ",")
'ID数を取得
lngCount = UBound(vntResult) + 1
'出力シートに就いて
With rngResult
'出力範囲の書式を文字列に設定
' .Offset(lngRow).Resize(lngCount, clngColumns + 1).NumberFormatLocal = "@"
'IDを出力
.Offset(lngRow).Resize(lngCount).Value _
= Application.Transpose(vntResult)
'項目1、項目2、項目3・の値を出力
.Offset(lngRow, 1).Resize(lngCount, clngColumns).Value _
= rngList.Offset(i, 1).Resize(, clngColumns).Value
End With
'出力行位置を更新
lngRow = lngRow + lngCount
Next i
strProm = "処理が完了しました"
Wayout:
Set rngResult = Nothing
Set rngList = Nothing
' Application.ScreenUpdating = True
Beep
MsgBox strProm
End Sub
|
|
Hirofumi
- 05/7/17(日) 21:16 -
