Excel VBA質問箱 IV

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

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


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

【59222】セル内の文字列の比較VBAの改変 PN 08/12/2(火) 18:20 質問[未読]
【59223】Re:セル内の文字列の比較VBAの改変 n 08/12/2(火) 18:31 発言[未読]
【59227】Re:セル内の文字列の比較VBAの改変 PN 08/12/2(火) 21:20 発言[未読]
【59229】Re:セル内の文字列の比較VBAの改変 n 08/12/2(火) 21:26 発言[未読]
【59232】申し訳ありません。 PN 08/12/2(火) 21:39 お礼[未読]
【59231】Re:セル内の文字列の比較VBAの改変 Hirofumi 08/12/2(火) 21:37 発言[未読]
【59233】ダブルで回答をありがとうございます。 PN 08/12/2(火) 21:42 お礼[未読]

【59222】セル内の文字列の比較VBAの改変
質問  PN  - 08/12/2(火) 18:20 -

引用なし
パスワード
   お世話になっています。

このVBAで「D」にあって「B」に無い文字列を「F」に抽出しています。
ただ「D」に同じ文字列が複数あった場合、その文字列が「B」に一つでも有れば、
「F」には文字列が抽出されません。

「D」に同じ文字列が4つあって、「B」にその文字列が2つあった場合、
「F」にその文字列を2つ表示させるには、どのように変更すれば良いのでしょうか?

お手数ではありますが、ご教授頂ければ幸いです。


Sub 比較()
Dim tbl, i As Long
With CreateObject("Scripting.Dictionary")
 tbl = Range("d2", Range("d" & Rows.Count).End(xlUp)).Value
 For i = 1 To UBound(tbl, 1)
  If Not .Exists(tbl(i, 1)) Then
   .Add tbl(i, 1), Empty
  End If
 Next
 tbl = Range("b2", Range("b" & Rows.Count).End(xlUp)).Value
 For i = 1 To UBound(tbl, 1)
  If .Exists(tbl(i, 1)) Then
   .Remove tbl(i, 1)
  End If
 Next
 Range("f:f").ClearContents
 Range("f2").Resize(.Count).Value = Application.Transpose(.Keys)
End With
End Sub

【59223】Re:セル内の文字列の比較VBAの改変
発言  n  - 08/12/2(火) 18:31 -

引用なし
パスワード
   >If Not .Exists(tbl(i, 1)) Then
> .Add tbl(i, 1), Empty
>End If
ここで Item に Empty をセットするのではなく個数をカウントアップさせていく。
逆に
>If .Exists(tbl(i, 1)) Then
> .Remove tbl(i, 1)
>End If
こちらではカウントダウンさせて、0 になったら Remove する。

最後に Keys をLoopして書き出し用配列にItemに格納したカウント分のkeyをセットする。

...な感じで取りあえず出来そうです。

【59227】Re:セル内の文字列の比較VBAの改変
発言  PN  - 08/12/2(火) 21:20 -

引用なし
パスワード
   も、もう少し具体的に教えて貰えませんか?
まだ、学び始めたばかりのもので。。。

この比較が巧くいけば、処理がずっと楽になるエクセルファイルが出来上がるのです。

よろしくお願いします。

【59229】Re:セル内の文字列の比較VBAの改変
発言  n  - 08/12/2(火) 21:26 -

引用なし
パスワード
   Sub try()
  Dim i As Long
  Dim j As Long
  Dim tbl, tbl2, v, k

  With CreateObject("Scripting.Dictionary")
    tbl = Range("D2", Range("D" & Rows.Count).End(xlUp)).Value
    tbl2 = Range("B2", Range("B" & Rows.Count).End(xlUp)).Value
    For Each v In tbl
      .Item(v) = .Item(v) + 1
    Next
    For Each v In tbl2
      If .Exists(v) Then
        .Item(v) = .Item(v) - 1
        If .Item(v) = 0 Then .Remove v
      End If
    Next
    i = 0
    For Each k In .Keys
      For j = 1 To .Item(k)
        i = i + 1
        tbl(i, 1) = k
      Next
    Next
  End With
  Range("F:F").ClearContents
  Range("F2").Resize(i).Value = tbl
End Sub

こんな感じです。

【59231】Re:セル内の文字列の比較VBAの改変
発言  Hirofumi  - 08/12/2(火) 21:37 -

引用なし
パスワード
   Dictionaryじゃ無いけど、こんなので出来ると思います
D列、B列が、共に昇順で整列済みとします
D列、B列共に列見出しが有る物とします

Option Explicit
Option Compare Text

Public Sub Extraction2()

  Dim i As Long
  Dim rngList1 As Range
  Dim lngEnd1 As Long
  Dim vntList1 As Variant
  Dim lngRow1 As Long
  Dim rngList2 As Range
  Dim lngEnd2 As Long
  Dim vntList2 As Variant
  Dim lngRow2 As Long
  Dim lngExtract As Long
  Dim vntExtract As Variant
  Dim strProm As String

  'D列のD1を基準とします(データの上のセル位置)
  Set rngList1 = Worksheets("Sheet1").Cells(1, "D")
  
  'B列のB1を基準とする
  Set rngList2 = Worksheets("Sheet1").Cells(1, "B")
  
  '基準に就いて
  With rngList1
    '行数を取得
    lngEnd1 = .Offset(65536 - .Row).End(xlUp).Row - .Row
    If lngEnd1 < 0 Then
      strProm = "D列にデータが有りません"
      GoTo Wayout
    End If
    '品番列を配列に取得
    vntList1 = .Offset(1).Resize(lngEnd1).Value
    '結果用配列を確保
    ReDim vntExtract(1 To lngEnd1, 1 To 1)
  End With
  
  '基準に就いて
  With rngList2
    '行数を取得
    lngEnd2 = .Offset(65536 - .Row).End(xlUp).Row - .Row
    If lngEnd2 < 0 Then
      strProm = "B列にデータが有りません"
      GoTo Wayout
    End If
    '品目番号列を配列に取得
    vntList2 = .Offset(1).Resize(lngEnd2).Value
  End With
  
  '書き込み行を初期値に
  lngExtract = 0
  '"D列"の比較位置
  lngRow1 = 1
  '"B列"の比較位置
  lngRow2 = 1
  'D列若しくは,B列が最終行に達するまで繰り返し
  Do Until lngRow1 > lngEnd1 Or lngRow2 > lngEnd2
    '比較結果に就いて
    Select Case vntList1(lngRow1, 1)
      Case Is = vntList2(lngRow2, 1) 'Matchiした場合
        '両データの比較位置の更新
        lngRow1 = lngRow1 + 1
        lngRow2 = lngRow2 + 1
      Case Is > vntList2(lngRow2, 1) '"B列"固有値の場合
        '"B列"の比較位置を更新
        lngRow2 = lngRow2 + 1
      Case Is < vntList2(lngRow2, 1) '"D列"固有値の場合
        '出力位置を更新
        lngExtract = lngExtract + 1
        '結果配列に代入
        vntExtract(lngExtract, 1) = vntList1(lngRow1, 1)
        '"D列"の比較位置を更新
        lngRow1 = lngRow1 + 1
    End Select
  Loop
  
  '残った"D列"の固有値を出力
  For i = lngRow1 To lngEnd1
    '出力位置を更新
    lngExtract = lngExtract + 1
    '結果配列に代入
    vntExtract(lngExtract, 1) = vntList1(i, 1)
  Next i
  
  Application.ScreenUpdating = False

  '抽出データを書きこむ位置を指定
  With Worksheets("Sheet1").Cells(1, "F")
    .Offset(1).Resize(lngExtract).Value = vntExtract
  End With
    
  strProm = "処理が完了しました"
  
Wayout:
  
  Application.ScreenUpdating = True
  
  Set rngList1 = Nothing
  Set rngList2 = Nothing
    
  MsgBox strProm, vbInformation
  
End Sub

【59232】申し訳ありません。
お礼  PN  - 08/12/2(火) 21:39 -

引用なし
パスワード
   有難うございます。

作ってもらったような感じで申し訳ありません。

お蔭様で次のステップに進めそうです。

大変助かりました。

【59233】ダブルで回答をありがとうございます。
お礼  PN  - 08/12/2(火) 21:42 -

引用なし
パスワード
   まさか、ダブルで回答を貰えるとは思いませんでした。
ありがとうございます。

しかも、解説を含んでますので勉強になります。

お手間をお掛けしましたがお蔭様で、いいエクセルファイルができそうです。

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