Excel VBA質問箱 IV

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

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


11299 / 13644 ツリー ←次へ | 前へ→

【16870】文字列の比較、置換 KAME 04/8/13(金) 2:17 質問[未読]
【16871】Re:文字列の比較、置換 Hirofumi 04/8/13(金) 6:26 回答[未読]
【16872】Re:文字列の比較、置換 Muro 04/8/13(金) 10:22 お礼[未読]

【16870】文字列の比較、置換
質問  KAME  - 04/8/13(金) 2:17 -

引用なし
パスワード
   Sheet1には以下の座標が書かれています。

 A B C D…
1 G6 K8 V2 D7
2 U1 A9 J3 X5
3 M3 S6 R4 Q1
4 B9 T8 E1 Z6



Sheet2には以下の一覧が書かれています。

  A B 
1 赤 K8
2 黄 E1
3 黒 M3
4 茶 Z6



Sheet2のB列の文字を参照して、Sheet1の同じ文字が書かれた場所へ
Sheet2のA列の文字を置換するにはどのようにすればよいのでしょうか?
以下結果(こうしたい)

 A B C D
1   赤

3 黒
4     黄 黒

また、置換後に残ったSheet1の座標(Sheet2のB列に無い)文字は
消したいです。

ご教示お願い致します。

【16871】Re:文字列の比較、置換
回答  Hirofumi  - 04/8/13(金) 6:26 -

引用なし
パスワード
   こんな物かな?

Option Explicit

Public Sub Sample()

  Dim i As Long
  Dim j As Long
  Dim rngTop As Range
  Dim vntResult As Variant
  Dim rngList As Range
  
  '座標の有る表の左上隅の位置を設定
  Set rngTop = Worksheets("Sheet1").Cells(1, "A")
  '座標の有る表を配列に取得
  vntResult = rngTop.CurrentRegion.Value
  
  '置換する値の有るListの範囲を取得
  With Worksheets("Sheet2")
    Set rngList = Range(.Cells(1, "B"), _
              .Cells(65536, "B").End(xlUp))
  End With
  
  '座標の有る表の値を置換
  For i = 1 To UBound(vntResult, 1)
    For j = 1 To UBound(vntResult, 2)
      vntResult(i, j) _
        = RowSearch(vntResult(i, j), rngList)
    Next j
  Next i
  
  '座標の有る表を書き戻す
  With rngTop
    .Resize(UBound(vntResult, 1), _
        UBound(vntResult, 2)) = vntResult
  End With
  
  Set rngList = Nothing
  Set rngTop = Nothing
  
  Beep
  MsgBox "処理が完了しました"
  
End Sub

Private Function RowSearch(vntKey As Variant, _
            rngScope As Range) As Variant
  
' 一覧の探索

  Dim vntFound As Variant
  
  '一覧を探索して行位置を取得
  vntFound = Application.Match(vntKey, rngScope, 0)
  'エラーで無い場合(一覧に値が有る)
  If Not IsError(vntFound) Then
    '取得行の探索列左の値を返す
    RowSearch = rngScope(vntFound).Offset(, -1).Value
  End If
  
End Function

【16872】Re:文字列の比較、置換
お礼  Muro  - 04/8/13(金) 10:22 -

引用なし
パスワード
   ▼Hirofumi さん:
>こんな物かな?
>
>Option Explicit
>
>Public Sub Sample()
>
>  Dim i As Long
>  Dim j As Long
>  Dim rngTop As Range
>  Dim vntResult As Variant
>  Dim rngList As Range
>  
>  '座標の有る表の左上隅の位置を設定
>  Set rngTop = Worksheets("Sheet1").Cells(1, "A")
>  '座標の有る表を配列に取得
>  vntResult = rngTop.CurrentRegion.Value
>  
>  '置換する値の有るListの範囲を取得
>  With Worksheets("Sheet2")
>    Set rngList = Range(.Cells(1, "B"), _
>              .Cells(65536, "B").End(xlUp))
>  End With
>  
>  '座標の有る表の値を置換
>  For i = 1 To UBound(vntResult, 1)
>    For j = 1 To UBound(vntResult, 2)
>      vntResult(i, j) _
>        = RowSearch(vntResult(i, j), rngList)
>    Next j
>  Next i
>  
>  '座標の有る表を書き戻す
>  With rngTop
>    .Resize(UBound(vntResult, 1), _
>        UBound(vntResult, 2)) = vntResult
>  End With
>  
>  Set rngList = Nothing
>  Set rngTop = Nothing
>  
>  Beep
>  MsgBox "処理が完了しました"
>  
>End Sub
>
>Private Function RowSearch(vntKey As Variant, _
>            rngScope As Range) As Variant
>  
>' 一覧の探索
>
>  Dim vntFound As Variant
>  
>  '一覧を探索して行位置を取得
>  vntFound = Application.Match(vntKey, rngScope, 0)
>  'エラーで無い場合(一覧に値が有る)
>  If Not IsError(vntFound) Then
>    '取得行の探索列左の値を返す
>    RowSearch = rngScope(vntFound).Offset(, -1).Value
>  End If
>  
>End Function

ありがとうございます。
おかげさまで解決いたしました。

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