Excel VBA質問箱 IV

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

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


15816 / 76732 ←次へ | 前へ→

【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

1 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 回答

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