Excel VBA質問箱 IV

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

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


8 / 13618 ツリー ←次へ | 前へ→

【82249】別シートから一致する項目をすべて引っ張る(複数) 迷える羊 24/1/19(金) 13:21 質問[未読]

【82250】Re:別シートから一致する項目をすべて引っ... マナ 24/1/20(土) 13:10 発言[未読]
【82251】Re:別シートから一致する項目をすべて引っ... 迷える羊 24/1/21(日) 21:12 発言[未読]
【82252】Re:別シートから一致する項目をすべて引っ... マナ 24/1/21(日) 23:11 発言[未読]
【82253】Re:別シートから一致する項目をすべて引っ... 迷える羊 24/1/22(月) 11:28 質問[未読]
【82254】Re:別シートから一致する項目をすべて引っ... マナ 24/1/22(月) 12:58 発言[未読]
【82255】Re:別シートから一致する項目をすべて引っ... 迷える羊 24/1/22(月) 15:23 質問[未読]
【82257】Re:別シートから一致する項目をすべて引っ... マナ 24/1/22(月) 19:00 発言[未読]
【82263】Re:別シートから一致する項目をすべて引っ... 迷える羊 24/1/23(火) 17:10 質問[未読]
【82264】Re:別シートから一致する項目をすべて引っ... マナ 24/1/23(火) 20:05 発言[未読]
【82265】Re:別シートから一致する項目をすべて引っ... 迷える羊 24/1/24(水) 12:59 お礼[未読]

【82250】Re:別シートから一致する項目をすべて引...
発言  マナ  - 24/1/20(土) 13:10 -

引用なし
パスワード
   ▼迷える羊 さん:

Sheet2にあって、Sheet1にない項目はありますか
その逆、Sheet1にあって、Sheet2にない項目はありますか

【82251】Re:別シートから一致する項目をすべて引...
発言  迷える羊  - 24/1/21(日) 21:12 -

引用なし
パスワード
   ▼マナ さん:
>Sheet2にあって、Sheet1にない項目はありますか
>その逆、Sheet1にあって、Sheet2にない項目はありますか
sheet2はフルで網羅してありますので、
sheet2にあって、sheet1にない項目はあります。
sheet1にあってsheet2にない項目はありません。
よろしくおねがいいたします。

【82252】Re:別シートから一致する項目をすべて引...
発言  マナ  - 24/1/21(日) 23:11 -

引用なし
パスワード
   ▼迷える羊 さん:

Sub test()
  Dim ws1 As Worksheet, ws2 As Worksheet
  Dim c As Range
  Dim d As Object, k
  Dim v, i As Long, s As String
  Dim a As Object
  
  Set ws1 = Sheets("Sheet1")
  Set ws2 = Sheets("Sheet2")
  Set d = CreateObject("scripting.dictionary")
  
  For Each c In ws1.Columns(1).SpecialCells(xlCellTypeConstants)
    Set d(c.Value) = CreateObject("system.collections.arraylist")
  Next
  
  v = ws2.Cells(1).CurrentRegion.Value
  For i = 1 To UBound(v)
    s = v(i, 2)
    If d.exists(s) Then d(s).Add v(i, 1)
  Next
  
  Set a = CreateObject("system.collections.arraylist")
  
  For Each k In d.keys
    a.addrange dic(k)
  Next

  ws1.Cells(2).Resize(a.Count).Value = Application.Transpose(a.toarray)
  
End Sub

【82253】Re:別シートから一致する項目をすべて引...
質問  迷える羊  - 24/1/22(月) 11:28 -

引用なし
パスワード
   ▼マナ さん:

早々にご回答ありがとうございます!
>  Dim d As Object, k
kはVariantですかね?

また、
>  For Each k In d.keys
>    a.addrange dic(k)
のdicでSubまたはFunctionが定義されていないと言われてしまいました。

当初ユーザーフォームに入れていたせいかと思い、
標準モジュールに移動したのですが、
同じくだめでした。

【82254】Re:別シートから一致する項目をすべて引...
発言  マナ  - 24/1/22(月) 12:58 -

引用なし
パスワード
   ▼迷える羊 さん:


>>  Dim d As Object, k
>kはVariantですかね?

はい。Variantです。


>また、
>>  For Each k In d.keys
>>    a.addrange dic(k)
>のdicでSubまたはFunctionが定義されていないと言われてしまいました。
>

ごめんなさい。動作確認しないで投稿していました。
dic(k) でなく、d(k) でした。
 
 
     

【82255】Re:別シートから一致する項目をすべて引...
質問  迷える羊  - 24/1/22(月) 15:23 -

引用なし
パスワード
   ▼マナ さん:
ありがとうございます!
それらはうまく進むことができました!

ですが、
Set d(c.Value) = CreateObject("system.collections.arraylist")
がオートメーションエラーとなってしまいます、、
データをとても小さく数行にしてもエラーになってしまいます、

どうしたらよいか教えてほしいです、すみません。

【82257】Re:別シートから一致する項目をすべて引...
発言  マナ  - 24/1/22(月) 19:00 -

引用なし
パスワード
   ▼迷える羊 さん:

>Set d(c.Value) = CreateObject("system.collections.arraylist")
>がオートメーションエラーとなってしまいます、、


arraylistが使えない環境ということですね。
Excelの標準機能だけを使うようにしました。

Sub test2()
  Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
  Dim r As Range, c As Range

  
   Set ws1 = Sheets("Sheet1")
    Set ws2 = Sheets("Sheet2")
    
    ws1.Rows(1).Insert
    ws1.Cells(1).Resize(, 2).Value = Array("t1", "t2")
    ws2.Rows(1).Insert
    ws2.Cells(1).Resize(, 2).Value = Array("t2", "t1")
    
  Set ws3 = Worksheets.Add
  Set r = ws3.Cells(1)
  Set c = ws3.Cells(5).Resize(2)
  c(2).Formula = "=countif(" & ws1.Name & "!A:A,B2)>0"
  
  ws2.Cells(1).CurrentRegion.AdvancedFilter xlFilterCopy, c, r
  Set r = r.CurrentRegion
  
  With r.Worksheet.Sort
    .SortFields.Clear
    .SortFields.Add2 _
      Key:=r.Columns(2), _
      CustomOrder:=WorksheetFunction.TextJoin(",", True, ws1.Columns(1))
    .SetRange r
    .Header = xlYes
    .Apply
  End With
  
  r.AdvancedFilter xlFilterCopy, , ws1.Cells(2)
  
  Application.DisplayAlerts = False
  ws3.Delete
  Application.DisplayAlerts = True
    ws1.Rows(1).Delete
    ws2.Rows(1).Delete
    
    ws1.Activate
    
End Sub

【82263】Re:別シートから一致する項目をすべて引...
質問  迷える羊  - 24/1/23(火) 17:10 -

引用なし
パスワード
   ▼マナ さん:
ありがとうございます!
動きました!
が、大変申し訳ございません、
私が省略したばかりに。

それぞれのシートには項目名があり、
頂いたコードですと、それを消してしまいまして。
>r.AdvancedFilter xlFilterCopy, , ws1.Cells(2)
ここが引っかかって来てるのかなとはあたりをつけたものの。

ので、以下正確にやりたいことを記載し直させてください!
散々コード記載頂いておりますのに申し訳ございません。
[sheet1]13行目〜  [sheet2]1行目〜
名前(A列) #(B列)  #(H列) 名前(L列)
いちご       123   いちご
みかん       234   りんご
りんご       345   みかん
ぶどう       456   いちご
          567   りんご
          678   りんご

よろしくお願い致します。。

【82264】Re:別シートから一致する項目をすべて引...
発言  マナ  - 24/1/23(火) 20:05 -

引用なし
パスワード
   ▼迷える羊 さん:

Sub test3()
  Dim ws1 As Worksheet, ws2 As Worksheet
  Dim r1 As Range, r2 As Range
  Dim ws As Worksheet
  Dim r3 As Range, r4 As Range
  Dim c As Range, t As Range

  Set ws1 = Sheets("Sheet1")
  Set ws2 = Sheets("Sheet2")
  Set r1 = ws1.Range("A13")
  Set r2 = Union(ws2.Columns("H"), ws2.Columns("L"))
  
  Set ws = Worksheets.Add
  Set r3 = ws.Range("A1")
  Set r4 = ws.Range("C1")
  Range(r1, r1.End(xlDown)).Copy r3
  r2.Copy r4
  
  Set c = ws.Range("F1:F2")
   c(2).Formula = "=countif(A:A,D2)>0"
  Set t = ws.Range("H1")
  r4.CurrentRegion.AdvancedFilter xlFilterCopy, c, t
  Set t = t.CurrentRegion
  
  With ws.Sort
    .SortFields.Clear
    .SortFields.Add2 _
        Key:=t.Columns(2), _
        CustomOrder:=WorksheetFunction.TextJoin(",", True, r3.CurrentRegion)
    .SetRange t
    .Header = xlYes
    .Apply
  End With

  t.Columns(1).Copy r1.Offset(, 1)
  
  Application.DisplayAlerts = False
  ws.Delete
  Application.DisplayAlerts = True
  Application.Goto r1, True
    
End Sub

【82265】Re:別シートから一致する項目をすべて引...
お礼  迷える羊  - 24/1/24(水) 12:59 -

引用なし
パスワード
   ▼マナ さん:
無事動かすことができました!!
ありがとうございました!

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