CSVファイル出力(VBA)

CSV出力の条件指定について教えてください。

アウトプットのCSVのイメージは以下です。

最終アウトプットイメージ
20210401,東京,田中,shinagawa,○
20210401,東京,田中,shibuya,×
20210401,東京,田中,shinzyuku,○
20210401,東京,佐藤,shinagawa,○
20210401,東京,佐藤,shibuya,×
20210401,東京,佐藤,shinzyuku,○
20210401,東京,鈴木,shinagawa,○
20210401,東京,鈴木,shibuya,×
20210401,東京,鈴木,shinzyuku,○

★質問したい内容
・Shet1のB7からD7のセルの内容をSHEET2から取得し隣のセルの内容をCSVに出力する。
各都道府県があるのでB7～・・・・∞です。
※SHEET1は画像を添付します。
私の知識ではなんともできなかったので、ご教授お願いいたします。

SHEET2イメージ
　A B C D E F・・・・
1東京 　　　大阪 　　 福岡
2品川　 shinagawa 堺 　　 sakai 博多 hakata
3渋谷　 shibuya 錦 nishiki
4新宿　 shinzuku
5・
・
・

下記はソースです。
ub CSV作成()
Dim csvData As String
Dim lineData As String
Dim pointKey As String
Dim TrgRange As Range, R As Range, CEL As Range
With ActiveSheet
With .Range("A5").CurrentRegion
Set TrgRange = Intersect(.Cells, .Offset(1).Cells)

End With
csvData = ""
For Each R In TrgRange.Rows ' 行ループ
For Each CEL In R.Columns
If CEL.Value = "○" Or CEL.Value = "×" Then
If CEL.Value = "○" Then
pointKey = "01"
Else
pointKey = "02"
End If
lineData = .Cells(CEL.Row, 1) & "," & .Cells(CEL.Row, 2) & "," & .Cells(CEL.Row, 3) & "," & .Cells(4, CEL.Column) & "," & pointKey
★↑このセルの部分を修正して別テーブルの値を検索して取得するようにする。
If csvData = "" Then
csvData = lineData
Else '改行
csvData = csvData & vbCrLf & lineData
End If
End If
Next
Next
End With

Worksheets("Sheet2").Range("A1") = csvData ' CSV に書き込む全データ
Call FSO_csv(csvData)
End Sub

Sub FSO_csv(csvData As String)
Dim TS As Object ' TextStream

Dim fso As FileSystemObject
Set fso = New FileSystemObject


Dim ex_csvPath As String, ex_csvFileName As String
ex_csvPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" '暫定保存ファイルパス
ex_csvFileName = "TEST.csv" '暫定ファイル名
Set TS = fso.OpenTextFile(Filename:=ex_csvPath & ex_csvFileName, _
IOMode:=2, Create:=True)
TS.Write (csvData) ' CSV書き込み
TS.Close
Set TS = Nothing
Set fso = Nothing
End Sub

No.1 回答者： fujillin 回答日時： 2021/07/21 15:59

こんにちは

直接の回答ではありませんけれど・・・

ご提示のマクロはSheet1がアクティブな状態で実行するものと思いますが、ご提示のレイアウトから推測すると
＞With .Range("A5").CurrentRegion
＞Set TrgRange = Intersect(.Cells, .Offset(1).Cells)
＞End With
って、見当違いな範囲を取っていませんか？？
（見た目に空白なセルは、空白セルと仮定してですけれど・・・）
それで、現状は予定通りに動作しているのかどうか疑問です。

＞★↑このセルの部分を修正して別テーブルの値を検索して取得するようにする。
それでも動作するとは思いますけれど、データの回数分毎回検索処理をすることになってしまうので、大変効率が悪いと言えます。
仮に6行目が空き行なら、先に、6行目に都市名の変換後の値（品川→shinagawa）を表示しておけば、現状の仕組みのまま出力するセル位置を変えるだけで済むことになります。（現状の仕組みが動作しているのか疑問ですけれど…）
行は、6行目以外でも良いですし、処理が終わったら削除すれば良いでしょう。

都市名の変換はVBAで検索して行っても良いですし、関数を利用して求めても宜しいかと思います。
関数利用の場合は、（若干関数が長いですが）ご提示の例で言えば
Range("B6:D6").FormulaLocal = "=OFFSET(Sheet2!$A$1,MATCH(B7," & _
"OFFSET(Sheet2!$A:$A,0,MATCH($B4,Sheet2!1:1,0)-1),0)-1,MATCH($B4,Sheet2!1:1,0))"
などとしておくことで、まとめて処理が可能です。

この回答へのお礼

ご回答ありがとうございます。
＞って、見当違いな範囲を取っていませんか？？
＞（見た目に空白なセルは、空白セルと仮定してですけれど・・・）
＞それで、現状は予定通りに動作しているのかどうか疑問です。
こちら見当違いの場所を指定しておりました。


＞仮に6行目が空き行なら、先に、6行目に都市名の変換後の値（品川→shina＞gawa）を表示しておけば、現状の仕組みのまま出力するセル位置を変えるだけで済むことになります。（現状の仕組みが動作しているのか疑問ですけれど…）
＞行は、6行目以外でも良いですし、処理が終わったら削除すれば良いでしょう。
こちら空き行に変換後の値をfindメソッドで取得してエクセルの出力位置を変えるで実現はできたのですが
シート1の値と、シート2の同値の値を検索して、そこから別の値を取得するようなことが実現できるのかどうか知りたかったです。
できないのであれば、空き行に変換後の値をいれてCSVの出力と同時にその行を削除することしかできないのかな・・・と思いご質問させていただきました。

＞関数利用の場合は、（若干関数が長いですが）ご提示の例で言えば
＞Range("B6:D6").FormulaLocal = "=OFFSET(Sheet2!$A$1,MATCH(B7," & _
＞ "OFFSET(Sheet2!$A:$A,0,MATCH($B4,Sheet2!1:1,0)-1),0)-1,MATCH＞($B4,Sheet2!1:1,0))"
＞などとしておくことで、まとめて処理が可能です。
これはB6:D6に※空き行に変換後を入れたと想定したソースでしょうか？

お礼日時：2021/07/21 17:30

No.2 ベストアンサー 回答者： Qchan1962 回答日時： 2021/07/21 17:22

こんにちは

表組を変更したと言う事ですかね
SHEET2イメージが少し判り難いので画像を上げて頂いた方が良いかと
ちなみにC1が大阪ですかね

変更などの場合、前回のご質問アドレスを表示しておく方が内容が判り易いのではないかと思います。

Sub FSO_csv(csvData As String)についてはそのままで
データを検索から作るとした場合、キーをFindなどで範囲から特定して
抽出するようにします。
この場合のキーはB4の東京ですかね、その列がさらに地名を探す範囲になるかと、、

元コードの事もありますのでサンプルを示しますが、周知のとおり
VBAはデータ位置、シート名などが変わると正しく実行できなくなります。
実行される内容を理解するようにしないと改修する時に困ってしまいます。

私的には、多くの場合、理解して作ると言う事より、出来ているものから理解する方が学習効率が上がると思っている部分があり実行コードを無責任に書きますが、活用の仕方を含め自己責任で行ってください。

表組が少しわからない所がありますが、、どうでしょう

Sub sample()
Dim SH1 As Worksheet
Dim SH2 As Worksheet
Dim Key1 As String, Key2 As String, Key3 As String
Dim TrgCel As Range
Dim dataRng As Range

Dim csvData As String
Dim lineData As String
Dim TrgRange As Range, R As Range, CEL As Range

Set SH1 = Worksheets("Sheet1")
Set SH2 = Worksheets("Sheet2")
Key1 = SH1.Range("A4").Text
Key2 = SH1.Range("B4").Text

Set TrgCel = SH2.Range("A1", SH2.Range("A1").End(xlToRight)).Find(What:=Key2, LookAt:=xlWhole)
Set dataRng = SH2.Range(TrgCel, TrgCel.End(xlDown))

With SH1.Range("A7").CurrentRegion
Set TrgRange = Intersect(.Cells, .Offset(1, 1).Cells)
csvData = ""
For Each R In TrgRange.Rows ' 行ループ
For Each CEL In R.Columns
If CEL.Value = "○" Or CEL.Value = "×" Then
Key3 = dataRng.Find(What:=SH1.Cells(7, CEL.Column), LookAt:=xlWhole).Offset(, 1).Value
lineData = Key1 & "," & Key2 & "," & SH1.Cells(CEL.Row, 1) & "," & Key3 & "," & CEL.Value
If csvData = "" Then
csvData = lineData
Else '改行
csvData = csvData & vbCrLf & lineData
End If
End If
Next

Next
End With

'Worksheets("Sheet3").Range("A1") = csvData ' デバッグ確認　CSV に書き込む全データ
'Call FSO_csv(csvData) 'CSV出力処理へ

End Sub

結果出力部分はコメントアウトしています。
エラー対策は行っていません。

この回答へのお礼

Qchan1962様

返信が遅れてしまい申し訳ございません。

＞私的には、多くの場合、理解して作ると言う事より、出来ているものから理＞解する方が学習効率が上がると思っている部分があり実行コードを無責任に＞書きますが、活用の仕方を含め自己責任で行ってください。
セルの位置を変更してみた際にどのように変更すべきなのか勉強させていただいております。
先ほどソースコードを修正して実行した際に想定していた動きになりました。
ありがとうございます。

シートを変えてみたり同じような演習をいくつか試してみたいと思います。

ありがとうございました。

お礼日時：2021/07/27 15:37

No.3 回答者： fujillin 回答日時： 2021/07/22 01:57

No1です

＞これはB6:D6に※空き行に変換後を入れたと想定したソースでしょうか？
いいえ。セル範囲に関数式を設定するコードです。
関数式を設定すると、エクセルが計算してくれて、検索結果が表示されます。
出力時には、その（結果の）セル値を読み取ればよいという意味です。