Excel VBA質問箱 IV

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

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


33571 / 76734 ←次へ | 前へ→

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

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