Excel VBA質問箱 IV

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

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


5886 / 13645 ツリー ←次へ | 前へ→

【48377】検索し、置換するには? MAKI 07/4/15(日) 2:09 質問[未読]
【48378】Re:検索し、置換するには? Hirofumi 07/4/15(日) 8:03 回答[未読]
【48379】Re:検索し、置換するには? Hirofumi 07/4/15(日) 8:27 回答[未読]
【48382】Re:検索し、置換するには? Hirofumi 07/4/15(日) 15:32 回答[未読]
【48381】Re:検索し、置換するには? Kein 07/4/15(日) 11:44 回答[未読]
【48388】Re:検索し、置換するには? MAKI 07/4/15(日) 23:13 お礼[未読]

【48377】検索し、置換するには?
質問  MAKI  - 07/4/15(日) 2:09 -

引用なし
パスワード
   ズブのド素人です。

sheet1のA列も文字列とsheet2も文字列が一致したら、
sheet2の文字列をsheet1のB列の文字列に置換したいのです。

sheet1
A  B  C  D (600行くらい)
1A 101 4/5 ○
2A 102 4/5 ○    
3A 103 4/2 ○    
4A 104
1B 105 4/6 ○    
2B 106
3B 107
4B 108

sheet2       → 置換後
A  B  C  D  E   A  B  C  D  E        
1A           101
        2A                102
3A           103
  4A           104    
  1B  2B         105 106
      3B            107
        
sheet2は、ランダムに入力してあります。
重複データはありません。
どうぞ、よろしくご教授お願いします。

【48378】Re:検索し、置換するには?
回答  Hirofumi  - 07/4/15(日) 8:03 -

引用なし
パスワード
   何か、すごーく遅そう?

以下を標準モジュールに記述してください

Option Explicit

Public Sub Sample()

  Dim i As Long
  Dim j As Long
  Dim lngRows As Long
  Dim lngColumns As Long
  Dim rngList As Range
  Dim vntTable As Variant
  Dim lngIndex() As Long
  Dim rngResult As Range
  Dim vntData As Variant
  Dim vntFound As Variant
  Dim blnDirty As Boolean
  Dim strProm As String
  
  'Sheet1Listの左上隅セル位置を基準として設定
  Set rngList = Worksheets("Sheet1").Cells(1, "A")
  
  'Sheet2Listの左上隅セル位置を基準として設定
  Set rngResult = Worksheets("Sheet2").Cells(1, "A")
  
  With rngList
    'Sheet1データ行数を取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row + 1
    'データが無い場合
    If lngRows <= 1 And .Value = "" Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    'A、B列データを配列に取得
    vntTable = .Resize(lngRows, 2).Value
  End With
  'A、B列データをA列をKeyとして整列
  ReDim lngIndex(1 To lngRows)
  For i = 1 To lngRows
    lngIndex(i) = i
  Next i
  ShellSort vntTable, lngIndex
  
  With rngResult.Parent
    'Sheet2データ行数を取得
    lngRows = .UsedRange.Rows.Count
    '行が無い場合
    If lngRows <= 0 Then
      strProm = "Sheet2にデータが有りません"
      GoTo Wayout
    End If
    'Sheet2データ列数を取得
    lngColumns = .UsedRange.Columns.Count
    '列が1の場合
    If lngColumns <= 0 Then
      lngColumns = 2
    End If
  End With
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  'Sheet2を行単位で処理
  With rngResult
    For i = 0 To lngRows - 1
      '1行のデータを配列に取得
      vntData = .Offset(i).Resize(, lngColumns).Value
      '置き換えFlagをクリア
      blnDirty = False
      '行の先頭〜最終列まで繰り返し
      For j = 1 To lngColumns
        'データが""では無い場合
        If vntData(1, j) <> "" Then
          'Sheet1のA列から、データを探索
          vntFound = BinarySearch(vntData(1, j), vntTable, lngIndex)
          '一致するデータが有った場合
          If vntFound <> "" Then
            'データを置換
            vntData(1, j) = vntFound
            '置き換えFlagを立てる
            blnDirty = True
          End If
        End If
      Next j
      '置き換えが有った場合
      If blnDirty Then
        '行データを出力
        .Offset(i).Resize(, lngColumns).Value = vntData
      End If
    Next i
  End With
  
  strProm = "処理が完了しました"
  
Wayout:
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
  Set rngResult = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

Private Function BinarySearch(vntKey As Variant, _
                vntScope As Variant, _
                lngIndex() As Long) As Variant

'  二進探索

  Dim lngLow As Long
  Dim lngHigh As Long
  Dim lngMiddle As Long
  
  lngLow = LBound(lngIndex, 1)
  lngHigh = UBound(lngIndex, 1)
  
  Do While lngLow <= lngHigh
    lngMiddle = (lngLow + lngHigh) \ 2
    Select Case vntScope(lngIndex(lngMiddle), 1)
      Case Is < vntKey
        lngLow = lngMiddle + 1
      Case Is > vntKey
        lngHigh = lngMiddle - 1
      Case Is = vntKey
        lngLow = lngMiddle + 1
        lngHigh = lngMiddle - 1
    End Select
  Loop
  
  If lngLow = lngHigh + 2 Then
    BinarySearch = vntScope(lngIndex(lngMiddle), 2)
  Else
    BinarySearch = Empty
  End If

End Function

Private Sub ShellSort(vntList As Variant, _
          lngIndex() As Long, _
          Optional lngKey As Long = 1)

  Dim i As Long
  Dim j As Long
  Dim lngGap As Long
  Dim lngTmp As Long
  Dim lngTop As Long
  Dim lngEnd As Long
  
  lngTop = LBound(lngIndex, 1)
  lngEnd = UBound(lngIndex, 1)
  
  lngGap = 1
  Do While lngGap < (lngEnd - lngTop + 1) \ 3
    lngGap = 3 * lngGap + 1
  Loop
  
  Do Until lngGap = 0
    For i = lngGap + lngTop To lngEnd
      lngTmp = lngIndex(i)
      For j = i To lngGap + lngTop Step -lngGap
        If vntList(lngIndex(j - lngGap), lngKey) _
                  <= vntList(lngTmp, lngKey) Then
          Exit For
        End If
        lngIndex(j) = lngIndex(j - lngGap)
      Next j
      lngIndex(j) = lngTmp
    Next i
    lngGap = lngGap \ 3
  Loop

End Sub

【48379】Re:検索し、置換するには?
回答  Hirofumi  - 07/4/15(日) 8:27 -

引用なし
パスワード
   'Dictionaryを使うとコードが幾らか簡単に成ります?
'でも、遅そう?

Option Explicit

Public Sub Sample2()

  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 vntData As Variant
  Dim blnDirty As Boolean
  Dim dicIndex As Object
  Dim strProm As String
  
  'Sheet1Listの左上隅セル位置を基準として設定
  Set rngList = Worksheets("Sheet1").Cells(1, "A")
  
  'Sheet2Listの左上隅セル位置を基準として設定
  Set rngResult = Worksheets("Sheet2").Cells(1, "A")
  
  'Dictionaryオブジェクトを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")
  
  With rngList
    'Sheet1データ行数を取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row + 1
    'データが無い場合
    If lngRows <= 1 And .Value = "" Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    'A、B列データを配列に取得
    vntData = .Resize(lngRows, 2).Value
  End With
  'A、B列データをA列をKeyとしてdicIndexに登録
  With dicIndex
    For i = 1 To lngRows
      '既に登録が無い場合
      If Not .Exists(vntData(i, 1)) Then
        '登録
        dicIndex(vntData(i, 1)) = vntData(i, 2)
      End If
    Next i
  End With
  
  With rngResult.Parent
    'Sheet2データ行数を取得
    lngRows = .UsedRange.Rows.Count
    '行が無い場合
    If lngRows <= 0 Then
      strProm = "Sheet2にデータが有りません"
      GoTo Wayout
    End If
    'Sheet2データ列数を取得
    lngColumns = .UsedRange.Columns.Count
    '列が1の場合
    If lngColumns <= 0 Then
      lngColumns = 2
    End If
  End With
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  'Sheet2を行単位で処理
  With dicIndex
    For i = 0 To lngRows - 1
      '1行のデータを配列に取得
      vntData = rngResult.Offset(i).Resize(, lngColumns).Value
      '置き換えFlagをクリア
      blnDirty = False
      '行の先頭〜最終列まで繰り返し
      For j = 1 To lngColumns
        'データが""では無い場合
        If vntData(1, j) <> "" Then
          'Sheet1のA列から、一致するデータが有った場合
          If .Exists(vntData(1, j)) Then
            'データを置換
            vntData(1, j) = .Item(vntData(1, j))
            '置き換えFlagを立てる
            blnDirty = True
          End If
        End If
      Next j
      '置き換えが有った場合
      If blnDirty Then
        '行データを出力
        rngResult.Offset(i).Resize(, lngColumns).Value = vntData
      End If
    Next i
  End With
  
  strProm = "処理が完了しました"
  
Wayout:
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
  Set rngResult = Nothing
  Set dicIndex = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

【48381】Re:検索し、置換するには?
回答  Kein  - 07/4/15(日) 11:44 -

引用なし
パスワード
   Sheet1のA列をループして、Sheet2でFindメソッドの検索をするのが
一番シンプルで分かりやすいと思います。

Sub Data_Rep()
  Dim MyR As Range, C As Range, FR As Range

  With Sheets("Sheet1")
   Set MyR = .Range("A1", .Range("A65536").End(xlUp))
  End With
  For Each C In MyR
   Set FR = Sheets("Sheet2").Cells _
   .Find(C.Value, , xlValues, xlWhole)
   If Not FR Is Nothing Then
     FR.Value = C.Offset(, 1).Value
     Set FR = Nothing
   End If
  Next
  Set FR = Nothing
End Sub  

【48382】Re:検索し、置換するには?
回答  Hirofumi  - 07/4/15(日) 15:32 -

引用なし
パスワード
   ゴメン、「Public Sub Sample()」、「Public Sub Sample2()」も
以下の部分のコードが抜けていましたので追加して下さい

  With rngResult.Parent
    'Sheet2データ行数を取得
    lngRows = .UsedRange.Rows.Count
    '行が無い場合
    If lngRows <= 0 Then
      strProm = "Sheet2にデータが有りません"
      GoTo Wayout
    End If
    'Sheet2データ列数を取得
    lngColumns = .UsedRange.Columns.Count
    '列が1の場合
    If lngColumns <= 0 Then
      lngColumns = 2
    End If
    '入力範囲先頭を再設定 ★追加
    Set rngResult = .UsedRange.Item(1, 1) '★追加
  End With

【48388】Re:検索し、置換するには?
お礼  MAKI  - 07/4/15(日) 23:13 -

引用なし
パスワード
   firofumiさん、keinさん
ありがとうございます。
お蔭様で上手くいきました。
お礼が遅くなり申し訳ありません。

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