• 締切済み

【Excel】【VBA】重複しないリスト作成について

「データ」というシートのJ列データを元に、重複しないリストを 作成したいのですが、「データ」にレコードが1件しかないと > For Each c In varData で「型が一致しません」というエラーになってしまいます。 2件以上あると問題なく処理ができるのですが、1件のときに うまく回避させる方法はありますでしょうか。 'データシートのキーワードを重複しないリスト化してA列にコピー Dim sh2 As Worksheet Dim myDic As Object, myKey As Variant Dim c As Variant, varData As Variant Set sh2 = ThisWorkbook.Worksheets("Sheet1") Set myDic = CreateObject("Scripting.Dictionary") With ThisWorkbook.Worksheets("データ") varData = .Range("J3", .Range("J" & Rows.Count).End(xlUp)).Value End With For Each c In varData If Not c = Empty Then If Not myDic.Exists(c) Then myDic.Add c, Null End If End If Next myKey = myDic.Keys '出力 With sh2 .Range("A:A").ClearContents .Range("A4").Resize(myDic.Count) = Application.WorksheetFunction.Transpose(myKey) End With Set myDic = Nothing よろしくお願いいたします。

みんなの回答

  • NNAQ
  • ベストアンサー率56% (104/184)
回答No.2

'* =追加した行 If IsArray(varData) Then '* For Each c In varData '(中略) Next Else '* myDic.Add varData, Null '* End If '* myKey = myDic.Keys '出力 (以下同じ)

  • nag0720
  • ベストアンサー率58% (1093/1860)
回答No.1

c と varData は Range として定義したほうがいいでしょう。 ・・・ Dim c As Range, varData As Range ・・・ Set varData = .Range("J3", .Range("J" & Rows.Count).End(xlUp)) ・・・ If Not c.Value = Empty Then If Not myDic.Exists(c.Value) Then myDic.Add c.Value, Null ・・・

関連するQ&A

  • エクセルVBAで重複入力の排除

    すでに入力規則はリストで使用しております。 そのためVBAで重複入力の排除を行おうと思います。 一応以下のコードでできたのですが、もっと良い方法があったら教えてください。 お願いいたします。 Private Sub Worksheet_Change(ByVal Target As Range)    Dim myDic As Object    Dim c As Variant, varData As Variant    Dim i As Long    If Application.Intersect(Target, Range("A1:A50")) Is Nothing Then Exit Sub    Set myDic = CreateObject("Scripting.Dictionary")    varData = Range("A1:A50").Value    For Each c In varData      If Not c = Empty Then        i = i + 1        If Not myDic.Exists(c) Then          myDic.Add c, Null        End If      End If    Next    If myDic.Count < i Then     MsgBox Target & " は重複!"     Application.EnableEvents = False     Application.Undo     Application.EnableEvents = True    End If End Sub

  • エクセルVBA

    エクセル2003です 勉強中です 教えてください Sheet1     A      B      C       D      1   日付    種類    数量1    数量2  2   2月3日    C      300        10   3   2月4日     B      200       5 4   2月5日     A     100       20 5   2月3日     A     100       10 6   2月4日     B     200       5 7   2月5日     C     300       20 8   2月3日      A      300       20 9   2月4日     C      200        5 10  2月5日     B     100       10 Sheet1     F      G      H       I      1   日付    種類    数量1    数量2  2   2月3日    A      400          3   2月3日     C      300       4   2月4日     B     600       5   2月5日     A     100       6   2月5日     C     400       7 したい事 *A列~D列のデータをF列からI列へ複数条件の集計をしたいのですが *A列~D列の数値が変動すると勝手に自動で集計をして欲しい(シートがアクティブでなくても) *下記コードでC列までの集計ができますがD列の集計がわかりません  (増やそうとすると頭の中がぐちゃぐちゃになって・・・) *前回の集計が残ってしまう Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim myDic As Object, myKey, myItem Dim myVal, myVal2, myVal3 Dim i As Long Range("F2", Range("I" & Rows.Count).End(xlUp)).ClearContents Range("F1:I1").Value = Range("A1:D1").Value Set myDic = CreateObject("Scripting.Dictionary") ' データを配列に格納 myVal = Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 4).Value ' myDicへデータを格納 For i = 1 To UBound(myVal, 1) myVal2 = myVal(i, 1) & "_" & myVal(i, 2) If Not myVal2 = "_" Then If Not myDic.exists(myVal2) Then myDic.Add myVal2, myVal(i, 3) Else myDic(myVal2) = myDic(myVal2) + myVal(i, 3) End If End If Next 'Key,Itemの書き出し myKey = myDic.keys myItem = myDic.items For i = 0 To UBound(myKey) myVal3 = Split(myKey(i), "_") Cells(i + 2, 6).Value = myVal3(0) Cells(i + 2, 7).Value = myVal3(1) Cells(i + 2, 8).Value = myItem(i) Next Set myDic = Nothing '並べ替え Range("F2", Range("H" & Rows.Count).End(xlUp)).Sort _ Key1:=Range("F2"), Order1:=xlAscending, _ Key2:=Range("G2"), Order2:=xlAscending, _ Header:=xlGuess End Sub 頭のなかがこんがらがってしまいます お願いです 出来れば説明付きで教えていただけませんか よろしくお願いします

  • エクセルVBAのFINDの質問です。

    エクセルVBAのFINDの質問です。 シート1    A    B    C     D 1 コード1 コード2 コード3 名 称 2  4    1     1 3  4    2     2 4  4    3     1 シート2    A    B 1 コード1 名 称 2  1   名称1 3  2   名称2 やりたいことは、シート1のD列に、シート1のコード3をもとにシート2から名称を取得したいのです。 下記に記したプログラムだと最初のFINDNEXTは動くのですが、 2回目でエラーになってしまい、次を読んでくれません。 どなたか、ご教授頂けますでしょうか。 シート1の検索条件はコード1の"4"です。 シート1のコード1は重複キーで、一レコードずつ読んで行き、各レコード毎にシート2を読みたい のです。 Dim シート1 As Worksheet Dim シート2 As Worksheet Dim obj As Object Dim Lin As Integer Dim mykey As Integer Dim obj1 As Object Dim Lin1 As Integer Dim mykey1 As Integer Dim st_Lin As Integer Set シート1 = ThisWorkbook.Worksheets("シート1") Lin = シート1.Cells(シート1.Rows.Count, 1).End(xlUp).Row mykey = "4" Set obj = シート1.Range("A1", "A" & Lin).Cells.Find(What:=mykey, _ LookIn:=xlValues, _ lookat:=xlWhole, _ SearchOrder:=xlByColumns) If obj Is Nothing Then   MsgBox ("異常です")   Exit Sub Else   st_Lin = obj.Row   Do Until obj.Row <> st_Lin    Set obj = シート1.Range("A1", "A" & Lin).FindNext(obj)    If obj Is Nothing Then     Exit Do    Else     Set シート2 = ThisWorkbook.Worksheets("シート2")       With シート2          Lin1 = .Cells(シート2.Rows.Count, 1).End(xlUp).Row          mykey1 = シート1.Cells(obj.Row, 3).Value          Set obj1 = .Range("A1", "A" & Lin1).Cells.Find          (What:=mykey1,LookIn:=xlValues,lookat:=xlWhole,SearchOrder:=xlByColumns)          If obj1 Is Nothing Then           MsgBox ("名称取得できませんでした")           Exit Sub          Else            シート1.Cells(obj.Row, 4).Value = .Cells(obj1.Row, 2).Value          End If       End With    End If   Loop End If

  • EXCEL2000とEXCEL2003のVBAについて

    現在、EXCEL2000で下記のコードを実行しています。 が、EXCEL2003で実行すると、 .UsedRange.Copy myb のコードが実行されているのにコピー出来ていません。 ファイルは開いていて、エラーは出ていないのです。 問題点わかる方教えていただけますか? Sub 日別データ読込() Dim rngsaki As Range Dim pathmacrobook As String Dim namebook As String Dim motobook As Workbook Dim myb As Variant Set rngsaki = Workbooks("残高集計用.xls").Worksheets(3).Range("a2") pathmacrobook = ThisWorkbook.Path & "\CSV読込データ12\" namebook = Dir(pathmacrobook & "*.xls") Do While Not namebook = "" Set motobook = Workbooks.Open(pathmacrobook & namebook) Set myb = Workbooks("残高集計用.xls").Worksheets(3).Range("A65536").End(xlUp) With motobook.Worksheets("Sheet1") .UsedRange.Copy myb End With motobook.Close False namebook = Dir() Loop MsgBox "完了しました" End Sub

  • マクロ組んでみましたが、動きません・・・・TT

    当方ビギナーにつき、参考片手にマクロ組んでいますが、苦戦してます。 処理コメント追って頂くと、やりたいことわかって頂けると思うのですが、、 具体的にどこがいけないのか、ご指導願います。 Dim myDic As Object Dim wb1 As Workbook Dim wb As Workbook Dim ws As Worksheet Dim sh As Worksheet Dim myKey Dim Hiduke As Variant '出力確認 Dallc = MsgBox("抽出データは、営業ブック担当シートの行末尾に追加されます。", vbYesNo + vbExclamation, "出力確認") Select Case Dallc Case vbYes Set myDic = CreateObject("Scripting.Dictionary") Set wb1 = ThisWorkbook Application.ScreenUpdating = False '営業部ブックの中から担当シートを探す For Each sh In wb1.Worksheets If InStr(ActiveSheet.Name, "担当") Then End If Next '作成日時の確認 Hiduke = ActiveSheet.Range("B5") '他ブックシート貼り付けデータ抽出 ActiveSheet.Range("B5").AutoFilter Field:=1, Criteria1:="=" & Hiduke ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy '他フォルダの営業ブック読み込み、データ行末尾に追加上書き Workbooks.Open Filename:="C:\仕事\営業.xls" Worksheets("担当").Activate Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial With ActiveSheet .Columns("A:AC").EntireColumn.AutoFit Windows("営業.xls").Close End With 'MSGボックスNOの場合 Case vbNo Worksheets("edit").Activate End Select

  • 途中まで出来ているのですが‥(Dicへの複数item追加?)

       A   B   C   D   E    ←シート元 1 大区分 中区分 金額1 金額2 小区分  ←見出し行です。 2  A社 管理課 12000  3000  1 3  B社 総務課 10000  2000  1 4  C社 業務課  800 1000    3 5  A社 総務課           5 6  C社 製造課  600 5000    2 7  A社 製造課 15000        1 8  A社 管理課  300       1 9  B社 管理課  800 2000     4 10  D社 総務課 90000 9000     1 を大区分 中区分 小区分をKeyにして3要素が同じものをまとめて並び替えて集計するのですが(下記のように 金額1 金額2ごとに足し算)    A   B   C   D   E    ←シート集計 1 大区分 中区分 小区分金額1 金額2   ←見出し位置変更 2  A社 管理課  1 12000 3300 3  A社 総務課  5   4  A社 製造課  1 15000   5  B社 総務課  1 10000 2000 6  B社 管理課  4 8000 2000 以下省略 実際に作りたいものは、元シートの金額の項目が多いのです(列が飛び飛びに40位あります)今回の例でいえばCとDが CからF HからV ABからCHとなりそれぞれ金額3,4,5~50みたいになってます。私なりに下記のコードのように進めてますが、表題のようにDictionaryに複数のitemを追加する方法が解らないため、金額の項目ごとに算出を繰り返すという効率が悪い方法をとってます。どなたかご教示頂けると幸いです。 Sub 3keyと2要素() ’実際は40要素くらいある Dim OLDBOOK As Workbook Dim SH1 As Worksheet Dim SH2 As Worksheet Dim myDic As Object, myKey, myItem Dim myVal, myVal2, myVal3, myVal4, myVal5 Dim i As Long Set OLDBOOK = ThisWorkbook Set SH1 = OLDBOOK.Worksheets("元") Set SH2 = OLDBOOK.Worksheets("集計") SH2.Cells.ClearContents SH2.Range("A1:B1").Value = SH1.Range("A1:B1").Value SH2.Range("C1").Value = SH1.Range("E1").Value SH2.Range("D1:E1").Value = SH1.Range("C1:D1").Value Set myDic = CreateObject("Scripting.Dictionary") SH1.Select myVal = SH1.Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 5).Value For i = 1 To UBound(myVal, 1) myVal2 = myVal(i, 1) & "_" & myVal(i, 2) & "_" & myVal(i, 5) If Not myVal2 = "_" & "_" Then If Not myDic.exists(myVal2) Then myDic.Add myVal2, myVal(i, 3) Else myDic(myVal2) = myDic(myVal2) + myVal(i, 3) End If End If Next myKey = myDic.keys ' 書き出し とりあえず2要素   myItem = myDic.items For i = 0 To UBound(myKey) myVal3 = Split(myKey(i), "_") SH2.Cells(i + 2, 1).Value = myVal3(0) SH2.Cells(i + 2, 2).Value = myVal3(1) SH2.Cells(i + 2, 3).Value = myVal3(2) SH2.Cells(i + 2, 4).Value = myItem(i) Next Set myDic = Nothing '******** Set myDic = CreateObject("Scripting.Dictionary") myVal = SH1.Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 5).Value For i = 1 To UBound(myVal, 1) myVal2 = myVal(i, 1) & "_" & myVal(i, 2) & "_" & myVal(i, 5) If Not myVal2 = "_" & "_" Then If Not myDic.exists(myVal2) Then myDic.Add myVal2, myVal(i, 4) Else myDic(myVal2) = myDic(myVal2) + myVal(i, 4) End If End If Next myKey = myDic.keys myItem = myDic.items For i = 0 To UBound(myKey) myVal3 = Split(myKey(i), "_") SH2.Cells(i + 2, 5).Value = myItem(i) Next Set myDic = Nothing ' 以下繰り返しするしかなく困ってます SH2.Select SH2.Range("A2", Range("E" & Rows.Count).End(xlUp)).Sort _ Key1:=Range("AF2"), Order1:=xlAscending, _ Key2:=Range("B"), Order2:=xlAscending, _ Key3:=Range("C2"), Order3:=xlAscending, _ Header:=xlGuess Set OLDBOOK = Nothing Set SH1 = Nothing Set SH2 = Nothing End Sub

  • VBA Excel2003 謎のエラー

    いろいろ検索してみたのですが、問題が解決できません。 エクセルのSheet1のA1からG16のセルの内容を一つずつ感知し、マイナスだったら赤、プラスだったら緑、それ以外だったら何もしないという処理にしたいです。 Private Sub Workbook_Open() ThisWorkbook.Sheets("Sheet1").Select ThisWorkbook.Sheets("Sheet1").Range("A1").Select Dim 英語 As Integer Dim 数字 As Integer Dim sheet1 As Worksheets sh1 = Worksheets("Sheet1") sh1.Activate 英語 = 1 数字 = 1 For 数字 = 1 To 16 For 英語 = 1 To 6 '選択位置が、マイナスだったら赤、プラスだったら緑、それ以外は無視 If Range(sh1.Cells(英語 & 数字)) < 0 Then Range(sh1.Cells(英語 & 数字)).Interior.ColorIndex = 7 ElseIf Range(sh1.Cells(英語 & 数字)) > 0 Then Range(sh1.Cells(英語 & 数字)).Interior.ColorIndex = 4 Else Range(sh1.Cells(英語 & 数字)).Interior.ColorIndex = 0 End If 英語 = 英語 + 1 Next 英語 数字 = 数字 + 1 Next 数字 End Sub

  • エクセルVBAでConsolidate

    以下は、ネット検索で見つけたサンプルコードです。 同じフォルダ内の全ブックのSheet1のA1:B10をThisWorkbookのSheet1に統合しています。 Sub test2() Dim MyFile As String, MyPath As String Dim SumFile() As Variant, i As Long MyPath = ThisWorkbook.Path & "\" MyFile = Dir(MyPath, vbNormal) Do Until MyFile = "" If MyFile <> ThisWorkbook.Name Then ReDim Preserve SumFile(i) 'A1からB10の値を変数に代入 SumFile(i) = "'" & MyPath & "[" & MyFile & "]Sheet1'!R1C1:R10C2" i = i + 1 End If MyFile = Dir Loop If i = 0 Then MsgBox "データが有りません": Exit Sub Worksheets("Sheet1").Range("A1").Consolidate Sources:=SumFile() End Sub 質問1 Sheet1だけでなく全シートのA1:B10をThisWorkbookのSheet1に統合するためにはどう書き換えればよいのでしょうか? 質問2 上記コードではなぜ、ブックを開かずにデータがとれるのでしょうか?

  • エクセルVBA抽出がうまく出来ません

    エクセル2013VBA初心者です。 入力シートからDBシートへ、DBシートから印刷シートへのデータ転記と印刷、入力内容のクリアまでは出来るようになりました。 DBシートの検索を行い、記録内容を入力シートに転記する抽出を行いたいのですが、下記構文を書いたところで問題が発生しました。 If Sh2.Range("A & i").Value = j And Sh2.Range("B & i").Value = k Then  でとまります。メッセージは ‘Range’メソッドは失敗しました:‘Workshieet’オブジェクトというものです。 やろうとしていることは、入力シートに設けた“E12”と”G12”の二つの検索項目をキーにDBシートの行を特定し、この行の内容を入力シートに反映しようということです。 入力シートの検索項目“E12”、 ”G12”はそれぞれDBシートのA列、B列に格納されている項目で、年度と連番です。サンプルとして入力シート"C5"に抽出しようとしているDBシートD列は申請者名です。 恐れ入りますがよろしくご教示頂きたく、お願い申し上げます。 Sub DBシートから力情報を抽出する () Dim Sh1 As Worksheet Dim Sh2 As Worksheet Dim i As Long Dim j As Long Dim k As Long Set Sh1 = Worksheets("入力") Set Sh2 = Worksheets("DB") j = Sh1.Range("E12").Value k = Sh1.Range("G12").Value With Sh2 For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row If Sh2.Range("A & i").Value = j And Sh2.Range("B & i").Value = k Then Sh1.Range("C5").Value = Sh2.Range("D & i").Value End If Next  End With End Sub

  • VBA .WorksheetFunctionについて

    Dim DestBook As Workbook Dim pathmacrobook As String Dim namebook As String Dim myb As Range Dim r As Long Application.ScreenUpdating = False ThisWorkbook.Activate pathmacrobook = ThisWorkbook.Path & "\" & Worksheets("sheet1").Cells(1, 3).Value & "\" Set DestBook = Workbooks("残高集計用.xls") namebook = Dir(pathmacrobook & "*.xls") Do While Not namebook = "" Set myb = DestBook.Worksheets("sheet3").Range("A65536").End(xlUp) With Workbooks.Open(pathmacrobook & namebook) r = aplication.WorksheetFunction.MatchThisWorkbook.Worksheets("sheet1") .Range("C3:AH3"), namebook.Worksheets("sheet1").Range("C"), 0) If r > 0 Then .Close False Else With Workbooks.Open(pathmacrobook & namebook) .Worksheets("Sheet1").UsedRange.Offset(1).Copy myb.Offset(1)      lngREC = lngREC + 1 .Close False End With End If namebook = Dir() Loop Set DestBook = Nothing MsgBox lngREC & "日分" & "読込完了しました" 上記のコードについてですが、修飾子が不正です。や、 Loopに対するDoがありません等エラーが出てしまいます。 やりたい事は、"namebook"を開いた時、"Thisworkbook"のsheet3のC列に"namebook"のsheet1のC列があれば、 "namebook"閉じ、そうでなければコピーするというようにしたいです。 どなたかご教授お願いします。

専門家に質問してみよう