| |
▼なのは さん：
こんにちは
正規表現を使わず、一般機能のみで書いてみました。(SampleB)
ちょっと力技のような感じで、あまりスッキリしていませんが。
（要件を誤解している部分あれば指摘ください）
なお、最初のテーマ、既に回答が出ており蛇足ですが、SampleAとして
あわせてアップします。
Sub SampleB()
Dim tblAV As Variant 'Table名の配列 転記シートA列用
Dim tblBV As Variant 'Table名の配列 転記シートB列用
Dim picV As Variant '各セルの( ) で囲まれた文字列の配列
Dim itemV As Variant '各セルの ( ) 内の要素の配列
Dim row3 As Long, i As Long, j As Long, k As Long, x As Long
Dim myA As Range, myC As Range
Dim sh3 As Worksheet
Application.ScreenUpdating = False
Set sh3 = Worksheets("SHeet3")
sh3.Columns("A:C").ClearContents
tblAV = Array("") '初期化
tblBV = tblAV '初期化
For Each myC In ActiveSheet.UsedRange
If Not IsEmpty(myC.Value) Then
If myC.Column = 1 Then
If Left(myC.Value, 7) = "(Table." Then _
Call tblSet(Mid(myC.Value, 8, Len(myC.Value) - 8), tblAV)
Else
If PickUp(myC.Value, picV) = True Then
For x = LBound(picV) To UBound(picV)
Call itemSet(picV(x), itemV, tblBV)
For i = LBound(tblAV) To UBound(tblAV)
For j = LBound(tblBV) To UBound(tblBV)
For k = LBound(itemV) To UBound(itemV)
row3 = row3 + 1
sh3.Range("A" & row3).Value = tblAV(i)
sh3.Range("B" & row3).Value = itemV(k)
sh3.Range("C" & row3).Value = tblBV(j)
Next
Next
Next
Next
End If
End If
End If
Next
sh3.UsedRange.NumberFormatLocal = "@"
Set sh3 = Nothing
Set myC = Nothing
Application.ScreenUpdating = True
End Sub
Private Sub tblSet(ByVal myStr As String, ByRef tblV As Variant)
Dim x As Long
tblV = Split(myStr, ",")
For x = LBound(tblV) To UBound(tblV)
tblV(x) = WorksheetFunction.Trim(tblV(x))
Next
End Sub
Private Function PickUp(ByVal myStr As String, _
ByRef picV As Variant) As Boolean
Dim s As String
Dim x As Long, z As Long
myStr = Replace(Replace(myStr, "(", vbTab & "\"), ")", vbTab)
picV = Split(myStr, vbTab)
For x = LBound(picV) To UBound(picV)
If Left(picV(x), 1) = "\" Then
picV(z) = Mid(picV(x), 2)
z = z + 1
End If
Next
If z > 0 Then
ReDim Preserve picV(z - 1)
PickUp = True
End If
End Function
Private Sub itemSet(ByVal myStr As String, ByRef itemV As Variant, _
ByRef tblV As Variant)
Dim x As Long
Dim v As Variant
Dim s As String
tblV = Array("")
x = InStr(myStr, "; Table.")
If x > 0 Then
s = Mid(myStr, x + 9)
Call tblSet(s, tblV)
myStr = Left(myStr, x - 1)
End If
itemV = Split(myStr, ",")
For x = LBound(itemV) To UBound(itemV)
itemV(x) = WorksheetFunction.Trim(itemV(x))
Next
End Sub
Sub SampleA()
Dim ofs As Long
Dim i As Long, j As Long, x As Long
Dim s As String
Dim v As Variant, w As Variant
Dim myA As Range, myC As Range
Application.ScreenUpdating = False
With ActiveSheet
On Error Resume Next
Intersect(.UsedRange, .UsedRange.Offset(, 1)).ClearContents 'B列以降をクリア
On Error GoTo 0
Set myA = .Range("A1:A" & .Range("A" & .Rows.Count).End(xlUp).Row) 'A列
End With
For Each myC In myA
ofs = 0
s = Replace(Replace(myC.Value, "(", vbTab & vbLf), ")", vbTab)
v = Split(s, vbTab)
For i = LBound(v) To UBound(v)
If Left(v(i), 1) = vbLf Then
s = Mid(v(i), 2)
w = Split(s, ",")
For j = LBound(w) To UBound(w)
ofs = ofs + 1
myC.Offset(, ofs).Value = w(j)
Next j
End If
Next i
Next
Set myA = Nothing
Set myC = Nothing
Application.ScreenUpdating = True
End Sub
|
|
UO3
- 10/9/2(木) 16:46 -
