| |
こんにちは。かみちゃん です。
Hirofumiさんではありませんが、
>また、新たに問題が出てきて困っています。
>
>列Aに(Table. 20B)の様にアルファベットを使用しているケースや
>(Table. 22, 22A, 22B)の様に複数テーブルがあるケースも同様に
>Sheet3に抽出し、
>列A 列B
>20B **(処理シートの列B以降の()の文字列）
>22 **
>22A **
>22B **
>
>
>列Aに(Table. 50)、列B以降の列に(510, 515; Table. 84L)や
>(100, 105A; Table. 90, 90A)の様な場合も
>Sheet3に下記の様に抽出しなければならなくなりました。
>列A 列B 列C
>50 510 84L
>50 515 84L
>50 100 90
>50 105A 90
>50 100 90A
>50 105A 90A
Hirofumiさんから修正案が出ればいいのですが、
Hirofumiさんのコードをできるだけ活かして修正すると以下のような感じにすると
上記の要件は対応できると思います。
（動作確認済みです）
Option Explicit
Public Sub Sample_3()
'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
Dim k As Long
'結果出力の先頭セル位置を基準とする
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)
vntNumber = Split(Mid(Left(vntData(1, 1), Len(vntData(1, 1)) - 1), InStr(1, vntData(1, 1), cstrKey, _
vbBinaryCompare) + Len(cstrKey)), ",")
End If
'転記するA列に書き込む元の文字列が有るなら
If Not IsEmpty(vntNumber) Then
'B列以降の列に就いて
For j = 2 To lngColumns
'B列以降の文字列の"()"の中を配列に取得
' vntResult = GetData(vntData(1, j))
vntResult = GetData2(vntData(1, j), cstrKey)
'結果が配列なら
If VarType(vntResult) = vbArray + vbVariant Then
For k = 0 To UBound(vntNumber)
'出力範囲に
With rngResult
With .Cells(lngRow, 2).Resize(UBound(vntResult, 2) + 1, 2)
'範囲を文字列に設定
.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)))
.Cells(lngRow, 1).Resize.Resize(UBound(vntResult, 2) + 1).Value _
= Trim(vntNumber(k))
End With
lngRow = lngRow + UBound(vntResult) + 1
Next k
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 GetData2(vntValue As Variant, cstrKey As String) 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
Dim i2 As Variant
Dim vntBuff2 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
'文字列を";"で分割
vntBuff2 = Split(vntBuff, ";")
'文字列に";"がない場合
If UBound(vntBuff2) = 0 Then
'文字列を","で分割
vntBuff = Split(vntBuff, ",")
'結果用配列に書き込み
For i = 0 To UBound(vntBuff)
'結果用配列を拡張
lngMax = lngMax + 1
ReDim Preserve vntResult(0 To 1, 0 To lngMax)
vntResult(0, lngMax) = Trim(vntBuff(i))
Next i
Else
'文字列を","で分割
vntBuff = Split(vntBuff2(0), ",")
'( )内のTableで始まる文字列を"," で分割
vntBuff2 = Split(Mid(Trim(vntBuff2(1)), InStr(1, Trim(vntBuff2(1)), cstrKey, _
vbBinaryCompare) + Len(cstrKey)), ",")
For i2 = 0 To UBound(vntBuff2)
'結果用配列に書き込み
For i = 0 To UBound(vntBuff)
'結果用配列を拡張
lngMax = lngMax + 1
ReDim Preserve vntResult(0 To 1, 0 To lngMax)
vntResult(0, lngMax) = Trim(vntBuff(i))
vntResult(1, lngMax) = Trim(vntBuff2(i2))
Next i
Next
End If
End If
'次の"("の位置を取得
lngPosF = InStr(lngPosR + 1, vntValue, cstrFront, vbTextCompare)
Loop
'戻り値として結果配列を返す
If lngMax > -1 Then
GetData2 = vntResult
End If
End Function
|
|
かみちゃん
- 10/9/2(木) 17:22 -
