Excel VBA質問箱 IV

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

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


2719 / 13644 ツリー ←次へ | 前へ→

【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 回答[未読]

【65808】()間の文字の抽出について
質問  なのは  - 10/6/29(火) 4:11 -

引用なし
パスワード
   列Aに
Aaa bbb (25A, 45A) ccc ddd, eee (261) fff (7, 44, 47).

とある場合に()間の文字を
列B 列C 列D 列E 列F 列G・・・
25A 45A 261 7  44  47

といったように抜き出したいと思っています。
列Aにある()の数は一個の時もあれば複数の時もあり不規則で
また、()の中の文字も同様に不規則です。
InStrで()の位置を検索してMidで抜き出せばできるのかな?と
思うのですが()が複数ある場合のコードはどの様に書けば良いか
検討がつきません。

申し訳ありませんが、どなたか教えて頂けないないでしょうか。

【65809】Re:()間の文字の抽出について
発言  ichinose  - 10/6/29(火) 5:25 -

引用なし
パスワード
   おはようございます。
>列Aに
>Aaa bbb (25A, 45A) ccc ddd, eee (261) fff (7, 44, 47).
>
>とある場合に()間の文字を
>列B 列C 列D 列E 列F 列G・・・
>25A 45A 261 7  44  47
>
>といったように抜き出したいと思っています。
正規表現を使ってみました。

標準モジュールに

'========================================================================
Sub test()
  Dim rng As Range
  Dim ele1 As Variant
  Dim result As Variant
  Dim crng As Range
  Dim pat As String
  Dim wk As Variant
  Dim g0 As Long
  Dim ele2 As Variant
  Set rng = Range("a1", Cells(Rows.Count, "a").End(xlUp))
  pat = "\([^(\(|\))]+\)"
  For Each crng In rng
    result = mymatches(crng.Value, pat)
    If TypeName(result) <> "Boolean" Then
     Dim distarray()
     g0 = 1
     For Each ele1 In result
       wk = Split(Mid(ele1, 2, Len(ele1) - 2), ",")
       For Each ele2 In wk
        ReDim Preserve distarray(1 To g0)
        distarray(g0) = ele2
        g0 = g0 + 1
       Next
     Next
     crng.Offset(0, 1).Resize(, UBound(distarray())).Value = distarray()
     Erase distarray()
    End If
  Next
  Set rng = Nothing
  Set crng = Nothing
End Sub
'=============================================================
Function mymatches(strng As Variant, pat As Variant) As Variant
  Dim regEx, Match, Matches
  Dim g0 As Long
  Dim ans() As Variant
  Set regEx = CreateObject("VBScript.RegExp")
  ' 正規表現を作成します。
  regEx.Pattern = pat
  regEx.IgnoreCase = True ' 大文字と小文字を区別しないように設定します。
  regEx.Global = True  ' 文字列全体を検索するように設定します。
  Set Matches = regEx.Execute(strng)  ' 検索を実行します。
  g0 = 1
  ReDim ans(1 To Matches.Count)
  For Each Match In Matches
   ans(g0) = Match.Value
   g0 = g0 + 1
  Next
  If Matches.Count > 0 Then
   mymatches = ans()
  Else
   mymatches = False
  End If
  Set regEx = Nothing
  Set Match = Nothing
  Set Matches = Nothing
  Erase ans()
End Function

アクティブシートのA列1行目から、

Aaa bbb (25A, 45A) ccc ddd, eee (261) fff (7, 44, 47).

このようなデータが入っているとすると、
上記testを実行してみてください。

【65813】Re:()間の文字の抽出について
質問  なのは  - 10/6/29(火) 9:27 -

引用なし
パスワード
   ichinose さんありがとうございます。
私がイメージした通りの事ができました。スゴイですね!
よろしければ、もうひとつ教えて頂きたいです。すみません。

アクティブなシートに下記の様にデータが入力されています。
列A   列B            列C        列D
(Table. 2)
『空白行』
(1)    Aa (5A, 10) bb (25B, 30).
『空白行』
     1)             Nn (35A) pp (45).
                  2)         Zz (46A, 47) za (48).
(b)    Gg hh iii j.
『空白行』
(Table. 3)
(a)    Kkk (70A) mm (75, 80).



同じ様に続きます。

先程と同じ様に()間の文字を抜き出したいのですが、
今度のモノは、空白行があったり、()が無かったり、片側)があったりします。
そして、抜き出した文字を別シートの列Bに書き出し
列Aにはアクティブなシートの列Aに入力されている
Table.番号を書き出したいと思っています。
Table。番号は必ず列Aに入っていますが、列B以降の列は不規則に入力されています。


列A  列B
2    5A
2    10
2    25B
2    30
2    35A
2    45
2    46A
2    47
2    48
3    70A
3    75
3    80
・   ・
・   ・
・   ・

可能でしょうか?
御迷惑でなければ教えてください。
先程教えて頂いたコードは一つずつ勉強させて頂きます。

【65846】Re:()間の文字の抽出について
回答  Hirofumi  - 10/6/30(水) 13:56 -

引用なし
パスワード
   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

【65878】Re:()間の文字の抽出について
お礼  なのは  - 10/7/4(日) 23:51 -

引用なし
パスワード
   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

【66380】Re:()間の文字の抽出について
発言  UO3  - 10/9/1(水) 22:05 -

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

こんばんは

おもしろそうなテーマなので時間があればコードを書いてみたいと思うのですが
【65813】の説明の中で
(1)    Aa (5A, 10) bb (25B, 30).
(b)    Gg hh iii j.
(a)    Kkk (70A) mm (75, 80).
といったサンプルが記載されていますが、この 1 や b や a は ( ) 内にあるものの
転記対象にはなっていませんね。
(1)、(b)、(a) これらは、どういう位置づけの文字列なんでしょうか?

【66382】Re:()間の文字の抽出について
発言  なのは  - 10/9/2(木) 6:51 -

引用なし
パスワード
   ▼UO3 さん:
文の段落となります。
Table. 2の1番目の文、Table. 2のb番目、Table. 3のa番目というように。
本来は、(1),(2),(3)・・・と順に段落がふられ、そのそれぞれの子として
(a),(b),(c)・・・と段落がふられ,その子がまたカッコ無しの1,2,3・・・
その子がまたカッコ無しのa,b,c・・・というように
列Aは段落となりますので特に抽出の必要がありませんので、無視しください。

【66383】Re:()間の文字の抽出について
発言  かみちゃん E-MAIL  - 10/9/2(木) 8:59 -

引用なし
パスワード
   こんにちは。かみちゃん です。

> 新たに問題が出てきて困っています。

新たな問題が出てくる前の質問の例であれば、Hirofumiさんのコードでうまくできているのでしょうか?
少なくとも、その報告は必要かと思います。

新たな問題の例を含めて、サンプルシートを整理すると以下のような感じなのでしょうか?

       A           B            C          D
1 (Table. 2)
2
3 (1)             Aa (5A, 10) bb (25B, 30).
4
5            1)             Nn (35A) pp (45).
6                         2)         Zz (46A, 47) za (48).
7 (b)          Gg hh iii j.
8
9 (Table. 3)
10 (a)          Kkk (70A) mm (75, 80).
11
12 (Table. 2B)
13 (a)          Jjj(80A) nn (85, 90).
14
15 (Table. 22, 22A, 22B)
16
17 (1)          Bb (6A, 20) cc (35B, 40).
18
19            1)             Oo (45A) qq (55).
20                         2)         Yy (56A, 57) ya (58).
21 (b)          Kk Ll mmm n.
22
23 (Table. 50)
24            (510, 515; Table. 84L)
25                         (100, 105A; Table. 90, 90A)
26

> 列Aに(Table. 20B)の様にアルファベットを使用しているケースや
> (Table. 22, 22A, 22B)の様に複数テーブルがあるケースも同様に

については、Hirofumiさんのコードを以下のように修正するとできます。

  Dim strProm As String
  
  Dim k As Long '★追加

  '結果出力の先頭セル位置を基準とする
  Set rngResult = Worksheets("Sheet3").Range("A1")

  ' 〜省略〜
 
      '転記する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)), ",") '★修正

  ' 〜省略〜

          For k = 0 To UBound(vntNumber) '★追加
            '出力範囲に
            With rngResult

              ' 〜省略〜

              '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) + 1).Value _
                = Trim(vntNumber(k)) '★修正
            End With
            lngRow = lngRow + UBound(vntResult) + 1
          Next k '★追加

  ' 〜省略〜

※マクロ初心者さんからのコメントもお待ちしています。
 なのはさんと違う方ならば・・・ですが。
 余計な詮索ですが、万が一、同一人であれば、お名前変えなくてもよかったと思います。
 回答者も事情がある場合がありますので、そういう場合は、なのはさんが
 「他の方でもいいのでどなたか教えてください」と言っていただければ、
 時間があって、向学心のある誰かがフォローします。

 ただ、後出し要件追加は、あまり好ましくありません。

【66384】Re:()間の文字の抽出について
発言  UO3  - 10/9/2(木) 9:19 -

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

回答ありがとうございます。
同一列の最初の(なんとか)は【無視】するということと理解しました。
もう1つ質問です。
(他の方々は、スイスイ理解されているようですが、年寄りですので理解力がどんどん低下中)


  A列      B列

(Table. AAA)  123,234,(456,567),678,789,(111A,222A; Table. BBB),890,901,(888,999)

このようになっていたとして、111Aと222Aが属するテーブルはBBBということは理解しましたが
888や999は、どのテーブルに属すのでしょうか。 AAA でしょうか、それともBBBでしょうか?

【66385】Re:()間の文字の抽出について
発言  かみちゃん E-MAIL  - 10/9/2(木) 9:30 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>  A列      B列
>
>(Table. AAA)  123,234,(456,567),678,789,(111A,222A; Table. BBB),890,901,(888,999)
>
>このようになっていたとして、111Aと222Aが属するテーブルはBBBということは理解しましたが
>888や999は、どのテーブルに属すのでしょうか。 AAA でしょうか、それともBBBでしょうか?

なのはさんから、コメントがあると思いますが、
( )内が"Table"で始まらず、その中に ; の後に続く文字列は、Sheet3のC列に転記するものであって、
( )内が"Table"で始まらず、その中に ; がない場合は、C列に転記する必要はないということではないでしょうか?

つまり、AAAでもなく、BBBでもないと考えています。
また、
A列に値がある場合は、B列以降は、値がないはずですが・・・

ちなみに、私は、スイスイ理解しているわけではなく、単純に、コメントがわかりづらいので、整理しただけです。
あと、「おもしろそうなテーマ」というわけではなく、
あくまで、VBAの勉強中でたまたま、見つけたという程度です。
実際、Hirofumiさんのコードは、いつも勉強させていただいています。

【66389】Re:()間の文字の抽出について
発言  UO3  - 10/9/2(木) 15:35 -

引用なし
パスワード
   ▼かみちゃん さん:

>Sheet3のC列に転記するものであって、

そうでしたね!読む読んでいませんでした。
ありがとうございます。

>あと、「おもしろそうなテーマ」というわけではなく、
>あくまで、VBAの勉強中でたまたま、見つけたという程度です。

おもしろそうなテーマというのは、もちろん、VBAの勉強のテーマとして
ということです。

【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

【66391】Re:()間の文字の抽出について
発言  かみちゃん E-MAIL  - 10/9/2(木) 17:22 -

引用なし
パスワード
   こんにちは。かみちゃん です。

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

【66392】Re:()間の文字の抽出について
発言  UO3  - 10/9/2(木) 17:26 -

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

ごめんなさい
デバッグ中のコードが、一部そのままになっていました。
SampleBのなかに2箇所、 "\" があります。
これを vbLf に修正願います。

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

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

こんにちは

SampleB の 別案です。
A列以外に (Table. ○○○) があると、A列のものと同等にみなされてしまいますが。

Option Explicit

Dim sh3 As Worksheet
Dim row3 As Long

Sub SampleB_2()
Dim allV As Variant
Dim allStr As String
Dim tblAv As Variant  'Table名の配列 転記シートA列用
Dim i As Long, j As Long, k As Long, x As Long, z As Long
Dim myC As Range

 z = WorksheetFunction.CountA(ActiveSheet.UsedRange)
 If z = 0 Then
  MsgBox "このシートは空白シートです"
  Exit Sub
 End If
 
 Application.ScreenUpdating = False
 allV = Array("") '配列化
 ReDim allV(1 To z)
 Set sh3 = Worksheets("SHeet3")
 sh3.Columns("A:C").ClearContents
 tblAv = Array("") '初期化
 z = 0
 
 For Each myC In ActiveSheet.UsedRange
  If Not IsEmpty(myC.Value) Then
   z = z + 1
   allV(z) = myC.Value
  End If
 Next
 
 Set myC = Nothing
 allStr = Join(allV, ",")
 allStr = Replace(allStr, "(Table.", vbTab & vbCr)
 allStr = Replace(allStr, ")", vbTab)
 allStr = Replace(allStr, "(", vbTab & vbLf)
 allV = Split(allStr, vbTab)
 
 For z = LBound(allV) To UBound(allV)
  If Left(allV(z), 1) = vbCr Then
   Call tblSet(Mid(allV(z), 2), tblAv)
  ElseIf Left(allV(z), 1) = vbLf Then
   Call itemSet(Mid(allV(z), 2), tblAv)
  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 Sub itemSet(ByVal myStr As String, ByRef tblAv As Variant)
 Dim itemV As Variant  '( ) 内の要素の配列
 Dim tblBV As Variant  'Table名の配列 転記シートB列用
 Dim x As Long, z As Long, i As Long, j As Long, k As Long
 Dim v As Variant
 Dim s As String
 tblBV = Array("")
 x = InStr(myStr, ";")
 If x > 0 Then
  z = InStr(x, myStr, "Table.")
  If z > 0 Then
   Call tblSet(Mid(myStr, z + 6), tblBV)
   myStr = Left(myStr, x - 1)
  End If
 End If
 itemV = Split(myStr, ",")
 For x = LBound(itemV) To UBound(itemV)
  itemV(x) = WorksheetFunction.Trim(itemV(x))
 Next
 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
End Sub

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