| |
ichinoseさんでは有りませんが？
InStrとMidを使って
Option Explicit
Public Sub Sample_2()
'Listの中のKeyと成る列位置(基準列からの列Offset：3列目)
Const cstrKey As String = "Table."
Dim i As Long
Dim j As Long
Dim lngRows As Long
Dim lngColumns As Long
Dim rngList As Range
Dim rngResult As Range
Dim vntNumber As Variant
Dim vntData As Variant
Dim vntResult As Variant
Dim lngRow As Long
Dim strProm As String
'結果出力の先頭セル位置を基準とする
Set rngResult = Worksheets("Sheet3").Range("A1")
With ActiveSheet.UsedRange
'Listの先頭セル位置を基準とする
Set rngList = .Cells(1, 1)
If .Count = 1 Then
strProm = "データが有りません"
GoTo Wayout
End If
'行列数の取得
lngRows = .Rows.Count
lngColumns = .Columns.Count
End With
'出力シートをクリア
rngResult.Parent.UsedRange.ClearContents
'画面更新を停止
Application.ScreenUpdating = False
'A列に就いて繰り返し
lngRow = 1
For i = 1 To lngRows
'1行分データを取得
vntData = rngList.Cells(i, 1).Resize(, lngColumns).Value
'A列の値に"Table."が入っていたなら
If InStr(1, vntData(1, 1), cstrKey, vbBinaryCompare) > 0 Then
'転記するA列に書き込む元の文字列に登録
vntNumber = vntData(1, 1)
End If
'転記するA列に書き込む元の文字列が有るなら
If Not IsEmpty(vntNumber) Then
'B列以降の列に就いて
For j = 2 To lngColumns
'B列以降の文字列の"()"の中を配列に取得
vntResult = GetData(vntData(1, j))
'結果が配列なら
If VarType(vntResult) = vbArray + vbVariant Then
'出力範囲に
With rngResult
With .Cells(lngRow, 2).Resize(UBound(vntResult) + 1)
'範囲を文字列に設定
.NumberFormat = "@"
'値を出力
.Value = Application.WorksheetFunction.Transpose(vntResult)
End With
'Table番号を出力
.Cells(lngRow, 1).Resize.Resize(UBound(vntResult) + 1).Value _
= Val(Mid(vntNumber, InStr(1, vntNumber, cstrKey, _
vbBinaryCompare) + Len(cstrKey)))
End With
lngRow = lngRow + UBound(vntResult) + 1
End If
Next j
End If
Next i
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
Private Function GetData(vntValue As Variant) As Variant
Const cstrFront As String = "("
Const cstrRear As String = ")"
Dim i As Long
Dim lngPosF As Long
Dim lngPosR As Long
Dim vntBuff As Variant
Dim lngMax As Long
Dim vntResult() As Variant
'"("、")"が無い時
lngMax = -1
'先頭の"("の位置を取得
lngPosF = InStr(1, vntValue, cstrFront, vbTextCompare)
'"("が無く成るまで繰り返し
Do Until lngPosF = 0
'"("の後ろの")"を探す
lngPosR = InStr(lngPosF + 1, vntValue, cstrRear, vbTextCompare)
'もし、")"が無いならDoを抜ける
If lngPosR = 0 Then
Exit Do
End If
'"("、")"の合い間の文字列を取得
vntBuff = Mid(vntValue, lngPosF + 1, lngPosR - lngPosF - 1)
'文字列が""で無い場合
If Trim(vntBuff) <> "" Then
'文字列を","で分割
vntBuff = Split(vntBuff, ",")
'結果用配列に書き込み
For i = 0 To UBound(vntBuff)
'結果用配列を拡張
lngMax = lngMax + 1
ReDim Preserve vntResult(lngMax)
vntResult(lngMax) = Trim(vntBuff(i))
Next i
End If
'次の"("の位置を取得
lngPosF = InStr(lngPosR + 1, vntValue, cstrFront, vbTextCompare)
Loop
'戻り値として結果配列を返す
If lngMax > -1 Then
GetData = vntResult
End If
End Function
また、最初の質問の回答として
「Private Function GetData」は「Public Sub Sample_2」と同じ物を使います
Public Sub Sample_1()
Dim i As Long
Dim lngRows As Long
Dim rngList As Range
Dim vntData As Variant
Dim strProm As String
'Listの先頭セル位置を基準とする
Set rngList = ActiveSheet.Range("A1")
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row + 1
If lngRows <= 1 And .Value = "" Then
strProm = "データが有りません"
GoTo Wayout
End If
End With
'画面更新を停止
Application.ScreenUpdating = False
With rngList
'A列に就いて繰り返し
For i = 1 To lngRows
'文字列の"()"の中を配列に取得
vntData = GetData(.Offset(i - 1).Value)
'結果が配列なら
If VarType(vntData) = vbArray + vbVariant Then
.Offset(i - 1, 1).Resize(, UBound(vntData) + 1).Value = vntData
End If
Next i
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
Hirofumi
- 10/6/30(水) 13:56 -
