Excel VBA質問箱 IV

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

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


16354 / 76732 ←次へ | 前へ→

【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
2 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 回答

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