Excel VBA質問箱 IV

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

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


33572 / 76734 ←次へ | 前へ→

【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
4 hits

【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 お礼

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