[[20171009154313]]　『VBA 同じ作業を自動化』（サク）　ページの最後に飛ぶ

『VBA 同じ作業を自動化』（サク）

VBA初心者です。
エクセルは2016です・

CSVで抽出したデータを対象の管理番号とマッチしたら残して、マッチしない場合は行ごと消していく。的なことをしたいです。

基本的には管理番号でマッチングさせています。
今まではVLOKUPでしておりましたが、ボタン一つでしたいと思いました。

例えば一つのブックに管理番号は
1234
1235
1236

とエクセルにあります。
こちらとマッチする行だけを残したいです。
CSV作業が多いのでどなたか回答お願い致します（＞＜）

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

今までの作業を箇条書きで書き出してください。
出きるだけ具体的に。

（マナ） 2017/10/09(月) 16:51

 csvファイルはデータベース形式に書かれていますか？
 (1行目にヘッダーがある)
（seiya） 2017/10/09(月) 17:29

早速のご返信誠に有難うございます。
必ずい行目には列ごとに項目があります。
必ず管理番号は抽出されますので、作業したい管理番号の入ったブックをベースに
上記のような作業をしたいと思っております。

最後には年月日を入れたファイル名に変更して指定したフォルダに保存までできると嬉しいです。
（サク） 2017/10/09(月) 17:41

 >例えば一つのブックに管理番号は 
 >1234 
 >1235 
 >1236

 これは抽出条件ですよね？
 どこに書かれていますか？

 条件項目名は 管理番号 ですか?
（seiya） 2017/10/09(月) 18:09

ダウンロードするcsvだと項目名は商品コードです。
探したい商品番号の方も項目名ないとvbaできないのでしょうか？？
（サク） 2017/10/09(月) 18:58

 >探したい商品番号の方も項目名ないとvbaできないのでしょうか？？
 此方には項目名は不要です。

 どのシートのどこに書かれていますか？
（seiya） 2017/10/09(月) 19:01

 新規ブックを立ち上げる。

 Sheet1のA1～Axに抽出したい商品コードを書き込んで下記コードを実行すると
 指定されたフォルダ・ファイル名で抽出されたデータを保存。

 Sub test()
     Dim myDir As String, fn As String, i As Long, myList, Dest As String
     Dim cn As Object, rs As Object, tempName As String, txt As String
     fn = Application.GetOpenFilename("CSVFiles,*.csv")
     If fn = "False" Then Exit Sub
     With Sheets("sheet1")
         myList = Join(Application.Transpose(.Range("A1", _
             .Range("A" & Rows.Count).End(xlUp)).Value), ",")
     End With
     myDir = Left$(fn, InStrRev(fn, "\"))
     fn = Mid$(fn, InStrRev(fn, "\") + 1)
     Dest = Application.GetSaveAsFilename(Format$(Date, _
                 "yyyy_mm_dd_") & fn, "CSVファイル,*.csv")
     If Dest = "False" Then Exit Sub
     Set cn = CreateObject("ADODB.Connection")
     Set rs = CreateObject("ADODB.Recordset")
     With cn
         .Provider = "Microsoft.Ace.OLEDB.12.0"
         .Properties("Extended Properties") = "Text;HDR=Yes;FMT=CSVDelimited"
         .Open myDir
     End With
     rs.Open "select * from `" & fn & "` where 商品コード in (" & myList & ")", cn, 3
     For i = 0 To rs.Fields.Count - 1
         txt = txt & "," & rs.Fields(i).Name
     Next
     Open Dest For Output As #1
         Print #1, Mid$(txt, 2) & vbCrLf & rs.GetString(2, , ",", vbCrLf)
     Close #1
     Set cn = Nothing: Set rs = Nothing
 End Sub

（seiya） 2017/10/09(月) 19:17

追加でご相談です。
ダウンロードするcsvデータのパターンが何種類かあるので、種類ごとに決まったフォルダに入れればそのフォルダのブックを指定すれば管理番号が入ったエクセルを元に自動化をなにかとできると思うのですがいかがでしょう？

例えば、自動化というフォルダ名を作成

 商品番号が入ったエクセルを入れてファイル名は実行処理
 また、カテゴリー 売上処理 在庫処理 などのフォルダを作成
 それらのフォルダの中にcsvデータを入れて処理が終われば日付が入ったファイル名で指定の場所に保存する。

考え方として如何でしょう？
（サク） 2017/10/09(月) 19:44

 まず、提示したコードを実行して期待通りの結果が得られるか確認してください。
（seiya） 2017/10/09(月) 19:46

fn = Application.GetOpenFilename("CSVFiles,*.csv")
のところでファイル選択画面になりますが、こちらは処理をしたいcsvを選択または管理コードが入ったエクセルどちらを選択するのでしょうか？

また、rs.Open "select * from `" & fn & "` where 管理コード in (" & myList & ")", cn, 3
はなにをしているのでしょうか？デバックがでました。
（サク） 2017/10/10(火) 14:39

 > 新規ブックを立ち上げる。
 新規ブックを立ち上げて、標準モジュールにコードを貼り付ける。

 >Sheet1のA1～Axに抽出したい商品コードを書き込んで下記コードを実行すると
 新規ブックのSheet1のA1～Axに抽出したい商品コードを書き込む。

 コードを実行して後、CSVファイルを選択、

 >指定されたフォルダ・ファイル名で抽出されたデータを保存。
 次に保存先を指定。

 ということです。
（seiya） 2017/10/10(火) 14:46

デバックのメッセージは
1つ以上の必要なパラメータの値が設定されていません。

とでております。
（サク） 2017/10/10(火) 15:02

 >必ずい行目には列ごとに項目があります。
 >ダウンロードするcsvだと項目名は商品コードです。

 ですよね？
 CSVファイルを(メモ帳)で開いて、１行目と2行目を此方に貼り付けてもらえませんか？
（seiya） 2017/10/10(火) 15:22

一行目
商品コード,カテゴリーコード,カテゴリー名,楽天市場1号店コントロールカラム,楽天市場1号店優先度,楽天市場1号店1ページ複数形式,楽天市場1号店カテゴリセット管理番号,Yahoo!ショッピング1号店表示順

二行目
30995957,276,アクセサリー(シャネル),u,2,,,2

いかがでしょうか？
（サク） 2017/10/10(火) 16:13

 此方で想定したとおりになっていますし、此方では期待通りに作動しています。

 一度

 >rs.Open "select * from `" & fn & "` where 商品コード in (" & myList & ")", cn, 3
 を
 rs.Open "select * from `" & fn & "`", cn, 3

 に変更して実行してみてください。
（seiya） 2017/10/10(火) 16:33

エラーはなくなりましたが、一列目の何個かの管理番号が消えて他の情報はそのままでした。
今回、実験として9個の管理コードを新規のブックに貼り付けております。

また、ダウンロードしているCSVには同じ管理番号が複数ずつ並んでおります。

商品コード,カテゴリーコード,カテゴリー名,楽天市場1号店コントロールカラム,楽天市場1号店優先度,楽天市場1号店1ページ複数形式,楽天市場1号店カテゴリセット管理番号,Yahoo!ショッピング1号店表示順

30995957,276,アクセサリー(シャネル),u,2,,,2
30995957,20,ピアス・イヤリング(Aアイテム別),u,2,,,1
72085578,12,綺麗でお買い得なんてやっべぇぞ！,u,2,,,4
72085578,276,アクセサリー(シャネル),u,2,,,3
72085578,18,ネックレス(Aアイテム別),u,2,,,1
105103074,12,綺麗でお買い得なんてやっべぇぞ！,u,2,,,4
105103074,352,BALENCIAGA/バレンシアガ,u,2,,,3
105103074,117,カード入れ・名刺入れ,u,2,,,1
523123783,4,初めて出会える個性ブランド特集☆,u,2,,,2
523123783,144,ラウンドファスナー長財布,u,2,,,1
802127005,370,財布(ブルガリ),u,2,,,2
802127005,152,ブルガリ(ラウンドファスナー)長財布,u,2,,,1
922137459,434,モノグラム,u,2,,,2
922137459,114,小物,u,2,,,1
922137459,437,小物(ルイヴィトン),u,2,,,3
925136289,277,アパレル(シャネル),u,2,,,1
925136289,39,ベルト(レディース),u,2,,,2
928137814,292,マトラッセ,u,2,,,2
928137814,6,新品未使用品が勢揃い,u,2,,,4
928137814,158,小銭入れ,u,2,,,1
928137814,301,小銭入れ(シャネル),u,2,,,3
J02139952,12,綺麗でお買い得なんてやっべぇぞ！,u,2,,,2
J02139952,434,モノグラム,u,2,,,3
J02139952,114,小物,u,2,,,1
J02139952,437,小物(ルイヴィトン),u,2,,,4
107102016,6,新品未使用品が勢揃い,u,2,,,4
107102016,117,カード入れ・名刺入れ,u,2,,,1
107102016,295,小物(シャネル),u,2,,,3

今一度ご指導をお願い致します（＞＜）

（サク） 2017/10/10(火) 16:45

 Sheet1のA1に　30995957
         A2に  802127005

 と入力して
 rs.Open "select * from `" & fn & "` where 商品コード in (" & myList & ")", cn, 3
 で実行すると

 商品コード,カテゴリーコード,カテゴリー名,楽天市場1号店コントロールカラム,楽天市場1号店優先度,楽天市場1号店1ページ複数形式,楽天市場1号店カテゴリセット管理番号,Yahoo_ショッピング1号店表示順 
30995957,276,アクセサリー(シャネル),u,2,,,2
30995957,20,ピアス・イヤリング(Aアイテム別),u,2,,,1
802127005,370,財布(ブルガリ),u,2,,,2
802127005,152,ブルガリ(ラウンドファスナー)長財布,u,2,,,1

 という新CSVファイルが生成されますが？
（seiya） 2017/10/10(火) 16:54

数字のみの管理コードはおっしゃられますとおり生成されました！
アルファベット（半角）のものがあると先ほどのデバックメッセージがでるようです。。

（サク） 2017/10/10(火) 17:18

 データ型が違うとうまくいきません。

 Sheet1の設定はそのままで、コードは下記と差し替えてください。

 Sub test()
     Dim fn As String, Dest As String, myDir As String
     Dim x, txt As String, a, i As Long, dic As Object
     fn = Application.GetOpenFilename("CSVFiles,*.csv")
     If fn = "False" Then Exit Sub
     With CreateObject("Scripting.FileSystemObject")
         x = Split(.OpenTextFile(fn).ReadAll, vbCrLf)
         myDir = .GetFile(fn).Path & "\"
         fn = .GetBaseName(fn) & "." & .GetExtensionName(fn)
     End With
     Dest = Application.GetSaveAsFilename(Format$(Date, _
                 "yyyy_mm_dd_") & fn, "CSVファイル,*.csv")
     If Dest = "False" Then Exit Sub
     Set dic = CreateObject("Scripting.Dictionary")
     dic.CompareMode = 1
     With Sheets("sheet1")
         a = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Resize(, 2).Value
     End With
     For i = 1 To UBound(a, 1)
         dic(CStr(a(i, 1))) = Empty
     Next
     txt = x(0)
     For i = 1 To UBound(x)
         If dic.exists(Split(x(i), ",")(0)) Then txt = txt & vbCrLf & x(i)
     Next
     Open Dest For Output As #1
         Print #1, txt
     Close #1
 End Sub

（seiya） 2017/10/10(火) 18:12

If dic.exists(Split(x(i), ",")(0)) Then

のところで
インデックスが有効範囲にありません。
とデバックがでました（＞＜）
（サク） 2017/10/10(火) 18:42

 おっと

 >     For i = 1 To UBound(x)
 >         If dic.exists(Split(x(i), ",")(0)) Then txt = txt & vbCrLf & x(i)
 >     Next

 を
      For i = 1 To UBound(x)
         If x(i) <> "" Then
             If dic.exists(Split(x(i), ",")(0)) Then txt = txt & vbCrLf & x(i)
         End If
      Next

　に変更してください。
（seiya） 2017/10/10(火) 18:55

アルファベットの分も生成されました！
ありがとうございます。

CSVの一行目の項目が違うものでしてみたらなにも生成されませんでした。
またそれにあったプログラムにしないといけないでしょうか？

管理コードだけはどのCSVにも入っております。

例えば
一行目
商品コード,商品名,想定在庫数,保留在庫数
二行目
80186457,トッズ TODS トートバッグバッググレー PVC×レザー【レディース】【中古】 ,0,0

などのように商品コードはという項目名は一緒ですが、他の列の項目名が多々ありまして。。
（サク） 2017/10/10(火) 19:15

 今実行されたコードはあくまでも商品コードが先頭(1列目)にあることが条件です。
 商品コード(又は他の抽出条件列)が1列目で無ければ、
　
 >Split(x(i), ",")(0)

 の 0 が一列目で 1は2列目 という具合になります。
（seiya） 2017/10/10(火) 19:24

すみません、今日あらためて実行してみると
生成されたデータは一行目だけあって何も抽出できておりませんでした。
昨日は確かにできていたのですが。。

プログラムはこちらです。

Option Explicit

Sub test()

     Dim fn As String, Dest As String, myDir As String
     Dim x, txt As String, a, i As Long, dic As Object
     fn = Application.GetOpenFilename("CSVFiles,*.csv")
     If fn = "False" Then Exit Sub
     With CreateObject("Scripting.FileSystemObject")
         x = Split(.OpenTextFile(fn).ReadAll, vbCrLf)
         myDir = .GetFile(fn).Path & "\"
         fn = .GetBaseName(fn) & "." & .GetExtensionName(fn)
     End With
     Dest = Application.GetSaveAsFilename(Format$(Date, _
                 "yyyy_mm_dd_") & fn, "CSVファイル,*.csv")
     If Dest = "False" Then Exit Sub
     Set dic = CreateObject("Scripting.Dictionary")
     dic.CompareMode = 1
     With Sheets("sheet1")
         a = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Resize(, 2).Value
     End With
     For i = 1 To UBound(a, 1)
         dic(CStr(a(i, 1))) = Empty
     Next
     txt = x(0)
     For i = 1 To UBound(x)
         If x(i) <> "" Then
             If dic.exists(Split(x(i), ",")(0)) Then txt = txt & vbCrLf & x(i)
         End If
      Next
     Open Dest For Output As #1
         Print #1, txt
     Close #1
 End Sub

また、一列目に全て商品コードがあるので、>Split(x(i), ",")(0)

 の 0 で大丈夫なはずです！

ご確認宜しくお願い致します。
（サク） 2017/10/11(水) 12:19

 当方では期待通りに抽出します...

 以下のコードで試してください。

 保存ファイル名を指定した後に、"条件項目名の入力" というインプットボックスが表示されますので
 商品コード 又は A列で条件設定した項目名を入力してください。

 Sub test()
     Dim fn As String, a, Dest As String, myDir As String, dic As Object
     Dim x, myCode As String, myIndex, i As Long, n As Long
     fn = Application.GetOpenFilename("CSVFiles,*.csv")
     If fn = "False" Then Exit Sub
     With CreateObject("Scripting.FileSystemObject")
         x = Split(.OpenTextFile(fn).ReadAll, vbCrLf)
         myDir = .GetFile(fn).Path & "\"
         fn = .GetBaseName(fn) & "." & .GetExtensionName(fn)
     End With
     Dest = Application.GetSaveAsFilename(Format$(Date, _
                 "yyyy_mm_dd_") & fn, "CSVファイル,*.csv")
     myCode = InputBox("条件項目名の入力")
     If myCode = "" Then Exit Sub
     myIndex = GetCodeIndex(x, myCode, ",")
     If IsError(myIndex) Then
         MsgBox "[" & myCode & "] は有効な項目ではありません。", 16
         Exit Sub
     End If
     If Dest = "False" Then Exit Sub
     Set dic = CreateObject("Scripting.Dictionary")
     dic.CompareMode = 1
     With Sheets("sheet1")
         a = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Resize(, 2).Value
     End With
     For i = 1 To UBound(a, 1)
         dic(CStr(a(i, 1))) = Empty
     Next
     For i = 0 To UBound(x)
         If x(i) <> "" Then
             If i < myIndex(1) Then
                 x(i) = vbNullString
             ElseIf i > myIndex(1) Then
                 If dic.exists(Split(x(i), ",")(myIndex(0))) Then
                     x(i) = vbCrLf & x(i): n = n + 1
                 Else
                     x(i) = vbNullString
                 End If
             End If
         End If
     Next
     Open Dest For Output As #1
         Print #1, Join(x, "")
     Close #1
     MsgBox n & " 件抽出"
 End Sub

 Function GetCodeIndex(x, myCode As String, delim As String)
     Dim i As Long, ii As Long, y, flg As Boolean
     Dim rowInd As Long, ColInd As Long
     For i = 0 To UBound(x)
         If x(i) <> "" Then
             y = Split(x(i), delim)
             For ii = 0 To UBound(y)
                 If LCase$(y(ii)) = LCase$(myCode) Then
                     rowInd = i: ColInd = ii: flg = True: Exit For
                 End If
             Next
         End If
         If flg Then Exit For
     Next
     If flg Then
         GetCodeIndex = Array(ColInd, rowInd)
     Else
         GetCodeIndex = CVErr(2042)
     End If
 End Function

（seiya） 2017/10/11(水) 12:50

インプットボックスで商品コードと入力すると、
商品コード有効な項目ではございません

とでます。。

選択したcsvファイルには間違いなくa1に商品コードとあるのですが。。
（サク） 2017/10/11(水) 12:57

 そのcsvファイルの項目行をこちらに貼り付けてもらえますか？
（seiya） 2017/10/11(水) 13:11

"商品コード","カテゴリーコード","カテゴリー名","楽天市場1号店コントロールカラム","楽天市場1号店優先度","楽天市場1号店1ページ複数形式","楽天市場1号店カテゴリセット管理番号","Yahoo!ショッピング1号店表示順"

昨日と同じになります。
一応他のファイルのも一行目を貼り付けます。

"商品コード","商品名","SKUコード","在庫管理タイプ","楽天市場1号店商品管理URL","Yahoo!ショッピング1号店商品コード","備考","ヤフオク!1号店出品指示","Yahoo!ショッピング1号店商品表示優先度","Yahoo!ショッピング1号店反映対象フラグ","楽天市場1号店反映対象フラグ","予備12"

"商品コード","商品名","想定在庫数","保留在庫数"

どちらも必ずa1に”商品コード”とございます
（サク） 2017/10/11(水) 13:20

 >"商品コード","....
 これダブルクォーツも込みですか？

 > 商品コード,カテゴリーコード,カテゴリー名,...
 になっていたはずですが？
（seiya） 2017/10/11(水) 13:25

emedtior形式で開いてコピペして送りましたが、確かに昨日は","なかったですね。。
同じやり方で提示したのですが。。

エクセル形式だと、a1 商品コード b2 カテゴリーコードと余計な空白などはないです、
システムからcsvをダウンロードしてるので、項目名は色々ありすが一行目の形式は一緒です。
（サク） 2017/10/11(水) 13:40

 では以下の2点を変更してください。

 1) Sub test()の

                 If dic.exists(Split(x(i), ",")(myIndex(0))) Then
                     x(i) = vbCrLf & x(i): n = n + 1
                 Else
 を
                 If dic.exists(Replace(Split(x(i), ",")(myIndex(0)), """", "")) Then 
                     x(i) = vbCrLf & x(i): n = n + 1
                 Else
 に差し替え。

 2) Function GetCodeIndex(x, myCode As String, delim As String)の

                 If LCase$(y(ii)) = LCase$(myCode) Then
                     rowInd = i: ColInd = ii: flg = True: Exit For
                 End If
 を
                 If LCase$(Replace(y(ii), """", "")) = LCase$(myCode) Then
                     rowInd = i: ColInd = ii: flg = True: Exit For
                 End If
 に差し替え。   
（seiya） 2017/10/11(水) 13:47

３種類ほどのCSVで試しましたが全て成功致しました！
感動です。

MSGBOXで商品コードと入力するところですが、
初期設定地で空白ではなく商品コードとでるようにするのは可能でしょうか？
（サク） 2017/10/11(水) 13:58

     myCode = InputBox("条件項目名の入力")
 を
     myCode = InputBox("条件項目名の入力", , "商品コード")
 に差し替えてください。
（seiya） 2017/10/11(水) 14:07

できました！
何件抽出と最後にでるのもわかりやすくて助かりました。
vlookupや並べ替え、削除に日々疲れていたので本当に感謝しております。
ありがとうございました！

あとはコードを解読できるよう勉強してみます！

他にも同じ作業があるのでお伺いしたいですが、掲示板が長くなりますので新規でご質問させて頂ければと思います。
（サク） 2017/10/11(水) 14:18

 様々な条件で試して、問題があるようならまた質問してください。
 今日はこれから出かけてしまいますので、返信できてもスマホからになると思います。
（seiya） 2017/10/11(水) 14:31

お忙しい中ご対応頂き有難うございました！
また何かございましたらよろしくお願い致します。
（サク） 2017/10/11(水) 14:45

先日作って頂いたコードですが、
抽出する行のタイトル名をmsgboxで管理コードなどで
探せるようにして頂きましたが、こちらcodeという名前ですると
0件と結果がでました。
どこのコードを書き直せばアルファベットでも大丈夫でしょうか？

また、一列目から管理コードなど見つけるようにしておりますが、三列目など列の場所を
変える場合はどこのコードを変えればよろしいでしょうか？

他のcsvで管理コードの列が一列目にない場合もございましたので、、

ご回答宜しくお願い致します
（サク） 2017/10/17(火) 14:38

 外出先ですので検証できませんが、
 コードは
 MsgBox に入力された文字列を探し、検出した行を
 タイトル行とみなします。

 その検出された列にフィルタをかけて結果を表示させます。
 従って、入力された文字列がタイトル行以前に出現した場合
 には、予期しない結果になります。

 その辺は私も危惧していました。
 何か考える必要がありますね。

 取り敢えず、問題のあったcsvの最初から数行をアップしてください。

（seiya） 2017/10/17(火) 15:30

一行目に
path,name,code,price,sale-price,pr-rate
です。
pathがa列で商品コードが抽出されております。
（サク） 2017/10/17(火) 16:49

 此方では、抽出条件が合致すれば期待通りの結果が得られています。
 抽出条件に半角、全角等の違いはありませんか？
（seiya） 2017/10/17(火) 17:11

すみません、pathではなくcodeが商品コードになりますので、
今回のだとc列が抽出条件になります。
申し訳ございません。
（サク） 2017/10/17(火) 18:20

 Function GetCodeIndex(x, myCode As String, delim As String)
 は、CSVの1行目からMsgBoxに入力された文字列を探して、一致した文字列のあった行と列を返します。
 (見つからなかった場合は、エラーを返しのちにMsgBoxで...有効な項目ではありません...が表示されて終わります。)

 そしてこの値を基にタイトル行の次行よりループして、シートのA列に書かれた条件に合致したものを抽出します。

 此方では、タイトル行が1行目(実際の値は0), Name の列が 3列目(実際の値は2)と返ってきています。
 ですので、その列の条件に合致値たものを抽出します。
 従って、抽出条件に合ったものが無ければ0件となります。

 試しに
 既提示された、csvのヘッダを変えて試しましたが期待通りの結果になっています。

 path,name,code,price,sale-price,pr-rate
ABCDEF,276,アクセサリー(シャネル),u,2,,,2 
ABCDEF,20,ピアス・イヤリング(Aアイテム別),u,2,,,1 
72085578,12,綺麗でお買い得なんてやっべぇぞ！,u,2,,,4 
72085578,276,アクセサリー(シャネル),u,2,,,3 
72085578,18,ネックレス(Aアイテム別),u,2,,,1 
105103074,12,綺麗でお買い得なんてやっべぇぞ！,u,2,,,4 
105103074,352,BALENCIAGA/バレンシアガ,u,2,,,3 
105103074,117,カード入れ・名刺入れ,u,2,,,1 
523123783,4,初めて出会える個性ブランド特集☆,u,2,,,2 
523123783,144,ラウンドファスナー長財布,u,2,,,1 
802127005,370,財布(ブルガリ),u,2,,,2 
802127005,152,ブルガリ(ラウンドファスナー)長財布,u,2,,,1 
922137459,434,モノグラム,u,2,,,2 
922137459,114,小物,u,2,,,1 
922137459,437,小物(ルイヴィトン),u,2,,,3 
925136289,277,アパレル(シャネル),u,2,,,1

 A列の条件
 アクセサリー(シャネル)
 財布(ブルガリ)

 で3件抽出されます。

（seiya） 2017/10/17(火) 18:44

抽出するCSVが
path,name,code,price,sale-price,pr-rate
"ブランド別:サ行:CHANEL/シャネル:小物(シャネル)
アイテム別:小物:カード入れ・名刺入れ
ブランド別:サ行:CHANEL/シャネル:人気コレクション(シャネル):マトラッセ
★お勧めページ:綺麗でお買い得なんてやっべぇぞ！",シャネル CHANEL カードケースコインケースマトラッセラムスキンパープルシルバー金具 A50169,313113370,55000,,15
"アイテム別:小物:キーリング
★お勧めページ:新品未使用品が勢揃い
ブランド別:ハ行:FENDHI/フェンディ",フェンディ FENDI マルチカラーチャーム PON PON CHARM バックチャームポンポンファーチャームピンク×キャメルファー×レザー 7AR259G31F0A67,317114787,40000,,15
"アイテム別:小物:手帳・手帳カバー
ブランド別:マ行:MIUMIU/ミュウミュウ",ミュウミュウ MIU MIU 手帳カバーアジェンダレザー本革グレーガンメタル金具シルバー金具,929137243,10000,,
"★お勧めページ:綺麗でお買い得なんてやっべぇぞ！
ブランド別:サ行:サルヴァトーレフェラガモ
アイテム別:財布:札入れ",サルヴァトーレフェラガモ Salvatore Ferragamo 財布札入れマネークリップ式レザーブルーシルバー金具 KD-66 9971,j12140185,20000,,
"★お勧めページ:新品仕上げ済みアイテム
ブランド別:カ行:Cartier/カルティエ:人気コレクションジュエリー(カルティエ):ラニエール(コレクション別)
ブランド別:カ行:Cartier/カルティエ:ジュエリー(カルティエアイテム別):リング(カルティエアイテム別)
アイテム別:ジュエリー(金・プラチナ）:リング(Jアイテム別):Cartier/カルティエ(Jリング)",【新品仕上げ】カルティエ Cartier ラニエールハーフダイヤモンドリング K18WG #48【新品同様】【新同】【レディース】【中古】,61124797,136000,,
"★お勧めページ:新品仕上げ済みアイテム
アイテム別:ジュエリー(金・プラチナ）:素材別(ジュエリー):2カラー
アイテム別:ジュエリー(金・プラチナ）:ペンダントトップ(Jアイテム別):Cartier/カルティエ(Jペンダントトップ)
ブランド別:カ行:Cartier/カルティエ:ジュエリー(カルティエアイテム別):ペンダントトップ(カルティエアイテム別)",カルティエ Cartier ダブルハートチャームトップ K18WG 750 18金ホワイトゴールド K18PG ピンクゴールド,D1156997,53000,,
"★お勧めページ:新品仕上げ済みアイテム
ブランド別:ハ行:BVLGARI/ブルガリ:ジュエリー(ブルガリ金・プラチナ):ペンダントトップ(ブルガリ)
アイテム別:ジュエリー(金・プラチナ）:ペンダントトップ(Jアイテム別):BVLGARI/ブルガリ(Jペンダントトップ)
アイテム別:ジュエリー(金・プラチナ）:素材別(ジュエリー):WG(ホワイトゴールド)",ブルガリ BVLGARI ペンダントトップハート K18WG 750 18金ホワイトゴールドチャームネックレスジュエリー,D1860402,35000,,
"★お勧めページ:新品仕上げ済みアイテム
ブランド別:タ行:Tiffany & Co/ティファニー:ジュエリー(ティファニー金・プラチナ):ネックレス(ティファニーアイテム別)
ブランド別:タ行:Tiffany & Co/ティファニー:人気コレクション(ティファニー):ハート
アイテム別:ジュエリー(金・プラチナ）:ネックレス(Jアイテム別):Tiffany&Co/ティファニー(Jネックレス)",ティファニー TIFFANY&Co センチメンタルハートネックレス 3P ダイヤモンド K18PG 750 18金ピンクゴールド,D1961385,82000,,
"★お勧めページ:新品仕上げ済みアイテム
ブランド別:ハ行:BVLGARI/ブルガリ:ジュエリー(ブルガリ金・プラチナ):ピアス・イヤリング(ブルガリ)
アイテム別:ジュエリー(金・プラチナ）:ピアス・イヤリング(Jアイテム別):BVLGARI/ブルガリ(Jピアス・イヤリング)
ブランド別:ハ行:BVLGARI/ブルガリ:B-ZERO1/ビーゼロワン人気コレクション",ブルガリ BVLGARI B-zero1 ピアス K18WG 750 18金ホワイトゴールドビーゼロワンイヤリングジュエリー,10860556,200000,,
"★お勧めページ:新品仕上げ済みアイテム
ブランド別:タ行:Tiffany & Co/ティファニー:ジュエリー(ティファニー金・プラチナ):ネックレス(ティファニーアイテム別)
ブランド別:タ行:Tiffany & Co/ティファニー:人気コレクション(ティファニー):ハート
アイテム別:ジュエリー(金・プラチナ）:ネックレス(Jアイテム別):Tiffany&Co/ティファニー(Jネックレス)",ティファニー TIFFANY&Co ラビングハートダイヤモンドネックレス K18YG 750 18金イエローゴールドペンダントジュエリー,11662545,60000,,

こちらからA列の条件
929137243
313113370
317114787
j12140185

で0件と抽出されます。

申し訳ございませんが今一度調査をお願い致します。
（サク） 2017/10/18(水) 10:54

 かなり不完全なCSVファイルですね。
 Sub test() を以下と差し替えてください。

 Sub test()
    Dim fn As String, a, Dest As String, myDir As String, dic As Object
    Dim x, y, myCode As String, myIndex, i As Long, n As Long
    fn = Application.GetOpenFilename("CSVFiles,*.csv")
    If fn = "False" Then Exit Sub
    With CreateObject("Scripting.FileSystemObject")
        x = Split(.OpenTextFile(fn).ReadAll, vbCrLf)
        myDir = .GetFile(fn).Path & "\"
        fn = .GetBaseName(fn) & "." & .GetExtensionName(fn)
    End With
    Dest = Application.GetSaveAsFilename(Format$(Date, _
                "yyyy_mm_dd_") & fn, "CSVファイル,*.csv")
    myCode = InputBox("条件項目名の入力", , "商品コード")
    If myCode = "" Then Exit Sub
    myIndex = GetCodeIndex(x, myCode, ",")
    If IsError(myIndex) Then
        MsgBox "[" & myCode & "] は有効な項目ではありません。", 16
        Exit Sub
    End If
    If Dest = "False" Then Exit Sub
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    With Sheets("sheet1")
        a = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Resize(, 2).Value
    End With
    For i = 1 To UBound(a, 1)
        dic(CStr(a(i, 1))) = Empty
    Next
    For i = 0 To UBound(x)
        If x(i) <> "" Then
            y = Split(x(i), ",")
            If i < myIndex(1) Then
                x(i) = vbNullString
            ElseIf i > myIndex(1) Then
                If UBound(y) >= myIndex(0) Then
                    If dic.exists(Replace(y(myIndex(0)), """", "")) Then
                        x(i) = vbCrLf & x(i): n = n + 1
                    Else
                        x(i) = vbNullString
                    End If
                Else
                    x(i) = vbNullString
                End If
            End If
        End If
    Next
    Open Dest For Output As #1
        Print #1, Join(x, "")
    Close #1
    MsgBox n & " 件抽出"
End Sub
（seiya） 2017/10/18(水) 11:42

有難うございます、できました！
複雑なcsvになるというのは空白が多いからとかでしょうか？？

基本的には商品コードがa列になくても最初に提示して頂いたコードで対応できるということでしょうか？
（サク） 2017/10/18(水) 13:07

 列数の足りない行がある
 という意味です。

 今のコードはタイトル列に関わらずA列に条件を設定するものになっています。
 もし事前にcsvの検索対象列が判明しているのなら、その列に応じたシート上の列に条件を予め設定しておく
 ということもできますね。

 Sub test()
    Dim fn As String, a, Dest As String, myDir As String, dic As Object
    Dim x, y, myCode As String, myIndex, i As Long, n As Long
    fn = Application.GetOpenFilename("CSVFiles,*.csv")
    If fn = "False" Then Exit Sub
    With CreateObject("Scripting.FileSystemObject")
        x = Split(.OpenTextFile(fn).ReadAll, vbCrLf)
        myDir = .GetFile(fn).Path & "\"
        fn = .GetBaseName(fn) & "." & .GetExtensionName(fn)
    End With
    Dest = Application.GetSaveAsFilename(Format$(Date, _
                "yyyy_mm_dd_") & fn, "CSVファイル,*.csv")
    myCode = InputBox("条件項目名の入力", , "商品コード")
    If myCode = "" Then Exit Sub
    myIndex = GetCodeIndex(x, myCode, ",")
    If IsError(myIndex) Then
        MsgBox "[" & myCode & "] は有効な項目ではありません。", 16
        Exit Sub
    End If
    MsgBox myCode & " は " & myIndex(0) + 1 & " 列目になります" & vbLf & _
           Replace(Cells(1, myIndex(0) + 1).Address(0, 0), 1, "") & " 列の条件で抽出。"
    If Dest = "False" Then Exit Sub
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    With Sheets("sheet1")
        a = .Range(.Cells(2, myIndex(0) + 1), .Cells(Rows.Count, myIndex(0) + 1).End(xlUp)).Resize(, 2).Value
    End With
    For i = 1 To UBound(a, 1)
        dic(CStr(a(i, 1))) = Empty
    Next
    If dic.Count = 0 Then
        MsgBox Replace(Cells(1, myIndex(0) + 1).Address(0, 0), 1, "") & " 列に条件が設定されていません。"
        Exit Sub
    End If
    For i = 0 To UBound(x)
        If x(i) <> "" Then
            y = Split(x(i), ",")
            If i < myIndex(1) Then
                x(i) = vbNullString
            ElseIf i > myIndex(1) Then
                If UBound(y) >= myIndex(0) Then
                    If dic.exists(Replace(y(myIndex(0)), """", "")) Then
                        x(i) = vbCrLf & x(i): n = n + 1
                    Else
                        x(i) = vbNullString
                    End If
                Else
                    x(i) = vbNullString
                End If
            End If
        End If
    Next
    Open Dest For Output As #1
        Print #1, Join(x, "")
    Close #1
    MsgBox n & " 件抽出"
End Sub

（seiya） 2017/10/18(水) 13:36

上記のコードで抽出条件codeのcsvで試しましたが0件となりました（＞＜）
（サク） 2017/10/18(水) 17:07

 抽出条件がシートのC列に列挙されていれば抽出されます。

 シートのC列

 C1  929137243
 C2  313113370
 C3  317114787
 C4 j12140185

 これで3件抽出。

（seiya） 2017/10/18(水) 17:16

はい、codeがc列にあるので抽出しますか？
とお知らせしてくれますので間違いなくc列の商品コードを探してると思うのですが
0件と結果でてしまいます。

csvは2017/10/18(水) 10:54 送付した内容です。
探して欲しい商品コードは今まで通り新規ブックのa列に入力しております。
（サク） 2017/10/18(水) 17:58

 >もし事前にcsvの検索対象列が判明しているのなら、その列に応じたシート上の列に条件を予め設定しておく
 >ということもできますね。

 ということで、A列にはcsvの1列目に対する条件　B列にはcsvの２2列目に対する条件というように、
 条件設定をする、という意味です。

 項目別に検索条件を列挙しておけば、項目を指定した段階でシート上の対応する列の条件で検索する、ということです

 その必要が無ければ、以前のコードで十分です。
（seiya） 2017/10/18(水) 18:05

コメント返信：

[ 一覧(最新更新順) ]

[[20171009154313]] 『VBA 同じ作業を自動化』（サク） ページの最後に飛ぶ

[[20171009154313]]　『VBA 同じ作業を自動化』（サク）　ページの最後に飛ぶ