Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


15823 / 76738 ←次へ | 前へ→

【66390】Re:()間の文字の抽出について
回答  UO3  - 10/9/2(木) 16:46 -

引用なし
パスワード
   ▼なのは さん:

こんにちは

正規表現を使わず、一般機能のみで書いてみました。(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

0 hits

【65808】()間の文字の抽出について なのは 10/6/29(火) 4:11 質問
【65809】Re:()間の文字の抽出について ichinose 10/6/29(火) 5:25 発言
【65813】Re:()間の文字の抽出について なのは 10/6/29(火) 9:27 質問
【65846】Re:()間の文字の抽出について Hirofumi 10/6/30(水) 13:56 回答
【65878】Re:()間の文字の抽出について なのは 10/7/4(日) 23:51 お礼
【66380】Re:()間の文字の抽出について UO3 10/9/1(水) 22:05 発言
【66382】Re:()間の文字の抽出について なのは 10/9/2(木) 6:51 発言
【66383】Re:()間の文字の抽出について かみちゃん 10/9/2(木) 8:59 発言
【66384】Re:()間の文字の抽出について UO3 10/9/2(木) 9:19 発言
【66385】Re:()間の文字の抽出について かみちゃん 10/9/2(木) 9:30 発言
【66389】Re:()間の文字の抽出について UO3 10/9/2(木) 15:35 発言
【66390】Re:()間の文字の抽出について UO3 10/9/2(木) 16:46 回答
【66392】Re:()間の文字の抽出について UO3 10/9/2(木) 17:26 発言
【66391】Re:()間の文字の抽出について かみちゃん 10/9/2(木) 17:22 発言
【66393】Re:()間の文字の抽出について UO3 10/9/2(木) 18:22 回答

15823 / 76738 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free