Excel VBA質問箱 IV

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

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


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

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

【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 お礼[未読]

【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