vbaマクロについて【シート2】をもとに【シート1】に有るものを｢有り.csv｣としてデスクトップ

Question

vbaマクロについて

【シート2】をもとに【シート1】に有るものを｢有り.csv｣としてデスクトップに保存、
無いものを｢無し.csv｣としてデスクトップに保存になるようマクロを作成したいです。
プログラムがわかるかた教えてください！

【シート1】
A    B         
1    りんご 
2    みかん 
3    なし     
4    ぶどう 
5    メロン 
6    バナナ 
7    かき     
8    いちご

【シート2】
A                                B
0003 なし                 500円
0009 パイナップル 1000円
0011 ざくろ             400円
0005 メロン             3000円
0001 りんご             100円
ーーーーー
【有り.csv】
A                                B
0003 なし                 500円
0005 メロン             3000円
0001 りんご             100円

【無し.csv】
A                                B
0009 パイナップル 1000円
0011 ざくろ             400円

Qchan1962 · Accepted Answer

こんばんは、ちょうど手持ちのコードでこんな感じ

Sub testExportCSV()
Dim Dic As Object
Dim V
Dim i As Long, j As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Worksheets("Sheet1")
    V = .Range("B1", .Cells(Rows.Count, "B").End(xlUp)).Value
End With
For i = 1 To UBound(V)
    If Not Dic.exists(V(i, 1)) Then Dic.Add V(i, 1), 0
Next
Dim V2
With Worksheets("Sheet2")
    V2 = .Range("A1", .Cells(Rows.Count, "A").End(xlUp)).Resize(, 3).Value
End With
Dim tmp1(), tmp2(), nasi, ari
Dim n As Long, k As Long
For i = 1 To UBound(V2, 1)
    If Not Dic.exists(V2(i, 2)) Then
        ReDim Preserve tmp1(2, n)
        tmp1(0, n) = V2(i, 1)
        tmp1(1, n) = V2(i, 2)
        tmp1(2, n) = V2(i, 3)
        n = n + 1
    Else
        ReDim Preserve tmp2(2, k)
        tmp2(0, k) = V2(i, 1)
        tmp2(1, k) = V2(i, 2)
        tmp2(2, k) = V2(i, 3)
        k = k + 1
    End If
Next
nasi = Application.Transpose(tmp1)
ari = Application.Transpose(tmp2)
Dim DesktopPath As String
Dim wsh As Object
Set wsh = CreateObject("WScript.Shell")
DesktopPath = wsh.SpecialFolders("Desktop")
Set wsh = Nothing
Set Dic = Nothing

If n > 0 Then Call outputCsv(nasi, DesktopPath & "\無.csv")
If k > 0 Then Call outputCsv(ari, DesktopPath & "\有.csv")
End Sub

Sub outputCsv(ByRef arrList, ByVal ExportFileName As String)
Dim i As Long, j As Integer
Dim strData As String '文字列
  Open ExportFileName For Output As #1
For i = LBound(arrList) To UBound(arrList, 1)
strData = ""
For j = 1 To UBound(arrList, 2)
If j = 1 Then
strData = arrList(i, j)
Else
strData = strData & "," & arrList(i, j)
End If
Next
Print #1, strData
Next
Close #1
End Sub

Qchan1962 · Answer

＞初心者にはなかなか理解が難しい
Scripting.Dictionaryオブジェクト、配列などを使用しているので判り難いですね。　余計分らなくなるかも知れませんが
新規ブックとシート関数を使用してcsv出力する例です
ロジックは少し分かり易いと思いますが
処理の速さ、上書きアラートなどに違いが生じると思います

Sub test_01()
Dim bDataSheet As Worksheet
Dim vDataSheet As Worksheet
'ThisWorkbookの各シートを変数にセット
'VBA実行ブックがアクティブブック
Set bDataSheet = Worksheets("Sheet1")
Set vDataSheet = Worksheets("Sheet2")
Dim bRng As Range, vRng As Range
'各データ範囲を変数にセット
Set bRng = bDataSheet.Range("B1:B" & bDataSheet.Range("B" & Rows.Count).End(xlUp).Row)
Set vRng = vDataSheet.Range("B1:B" & vDataSheet.Range("B" & Rows.Count).End(xlUp).Row)

Dim ariSheet As Worksheet
Dim nasiSheet As Worksheet
Application.ScreenUpdating = False
'作業用ブックを作成し各シートを変数にセット
Set ariSheet = Workbooks.Add.Sheets(1)
'シートを追加
Set nasiSheet = Sheets.Add(After:=Sheets(1))

Dim r As Range
Dim n As Long, k As Long
n = 1: k = 1 'セル行移動の変数　初期値は1
'照合するデータをループして基データに照合
For Each r In vRng
'シート関数で有無を判定　CountIf関数
If Application.CountIf(bRng, r) > 0 Then
'データ範囲はA～C列
'照合列がB列の為、基準を左に1ずらしサイズを列3分に変更　Offset(, -1).Resize(1, 3)
ariSheet.Cells(n, 1).Resize(1, 3).Value = r.Offset(, -1).Resize(1, 3).Value
n = n + 1
Else
nasiSheet.Cells(k, 1).Resize(1, 3).Value = r.Offset(, -1).Resize(1, 3).Value
k = k + 1
End If
Next

Dim wsh As Object
Dim DesktopPath As String
'現在のデスクトップパスをWScript.Shellで取得
Set wsh = CreateObject("WScript.Shell")
DesktopPath = wsh.SpecialFolders("Desktop")
Set wsh = Nothing
'作業用ブックのシートをcsvファイルで出力
'同名ファイルが存在する場合保存確認アラートが出ます
ariSheet.SaveAs Filename:=DesktopPath & "\有.csv", FileFormat:=xlCSV
nasiSheet.SaveAs Filename:=DesktopPath & "\無.csv", FileFormat:=xlCSV
'作業ブックを閉じる（Workbooks.Add以降ここまで新規ブックがアクティブ）
ActiveWorkbook.Close False
Application.ScreenUpdating = True
End Sub

Qchan1962 · Answer

こんにちは　時間がないのでChatGPTを活用
以下がChatGPTでの解説です
一部正しくないので添削しました
また、ソースを入れるとセキュリティチェックにかかるので削除しました　上部より順に解説されていますのでソースを見ながらご理解してください

このVBAコードは、ExcelのワークシートにあるデータをCSVファイルにエクスポートするためのコードです。以下、コードの各部分の解説をします。

スクリプト内で使用されるオブジェクトや変数を宣言しています。ここでは、Scripting.Dictionaryオブジェクトを使って一意の値を取得し、V、i、およびjという3つの変数を宣言しています。

ここでは、"Sheet1"という名前のワークシートにある"B"列のデータを取得し、Vに格納しています。このVは、ユニークな値を抽出するために使用されます。

これは、Vの要素を一つずつループし、Dicオブジェクトに格納します。Dicオブジェクトには、Vの要素の値が既に存在する場合は追加されず、存在しない場合にのみ追加されます。

ここでは、"Sheet2"という名前のワークシートにある"A"列のデータを取得し、V2に格納しています。

これは、V2の要素を一つずつループし、Dicオブジェクトに格納されていない値を持つものと、持たないものとを分割して、それぞれ、
ReDim Preserve tmp1(2, n)
ReDim Preserve tmp2(2, k)
tmp1とtmp2に都度拡張して格納しています
その為、1行目には列Aの値、2行目には列Bの値、3行目には列Cの値が格納されます。（拡張できるのは2次元側のみ）

nasi = Application.Transpose(tmp1)
ari = Application.Transpose(tmp2)
それぞれの値をApplication.Transpose()で反転させ、配列nasiとariに代入します。nasiとariはそれぞれ、1列目には列Aの値、2列目には列Bの値、3列目には列Cの値が格納されます。

次に、WScript.Shellオブジェクトを使って、デスクトップのパスを取得し、変数DesktopPathに代入します。そして、DicオブジェクトをNothingに設定し、メモリを解放します。

最後に、outputCsv()サブルーチンを呼び出して、nasiとariをそれぞれCSVファイルに出力します。CSVファイルのファイル名は、デスクトップに「無.csv」と「有.csv」として保存されます。

Sub outputCsv(ByRef arrList, ByVal ExportFileName As String)

outputCsv()サブルーチンでは、渡された2次元配列arrListをCSV形式で出力するための処理を行います。arrListは、1列目には列Aの値、2列目には列Bの値、3列目には列Cの値が格納された2次元配列です。

Openステートメントでファイルを開き、ForループでarrListの各行を処理します。strData変数に各行の値をカンマ区切りで連結し、Printステートメントでファイルに書き込みます。最後に、Closeステートメントでファイルを閉じます。

ちなみに処理速度は遅くなりますが　xlWBATWorksheet　を作り　
ワークシート関数などで出力してcsvで保存する等など　やり方は色々あります
あと、マルチはダメですよ

vbaマクロについて 【シート2】をもとに【シート1】に有るものを｢有り.csv｣としてデスクトップ

こんばんは、ちょうど手持ちのコードでこんな感じ

＞初心者にはなかなか理解が難しい

こんにちは 時間がないのでChatGPTを活用

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

vbaマクロについて【シート2】をもとに【シート1】に有るものを｢有り.csv｣としてデスクトップ

こんにちは　時間がないのでChatGPTを活用