アプリとChatGPTで、「データが空白の行は転記しない」VBAマクロを作成します。
事例 転記先の産地と単価を上書きする
「みかん」は空白で上書きされず、愛媛450のまま残っています。
出来ました😁
アプリの設定
アプリコードを作成します。
アプリへのリンク ⇒値が一致したら転記する
作成したコードは、転記元の空白が、転記先に空白が上書きされる問題が発生!🥲
ChatGPTで、アプリで作成したコードを修正
下記のコードの転記先の2列目と3列目が空白のときは、転記をしないコードを作成できますか?
とChatGPTに入力し、アプリで作成したコードを貼り付けます。
Sub デモ() '値が一致したら転記する Application.ScreenUpdating = False ' 画面描画を停止 Application.DisplayAlerts = False ' 警告表示を停止 '辞書オブジェクトの作成 Dim 辞書 As Object Set 辞書 = CreateObject("Scripting.Dictionary") '転記元の設定 Dim 最終行 As Long, 表配列() As Variant Sheets("Sheet1").Select 最終行 = Cells(Rows.Count, Range("a3").Column).End(xlUp).Row 表配列 = Range("a3" & ":" & Cells(最終行, Range("c3").Column).Address(False, False)).Value '辞書の作成 Dim キー As Variant, 対象行 As Long For 対象行 = 1 To UBound(表配列, 1) キー = 表配列(対象行,1) If 辞書.Exists(キー) Then Cells(Range("a3").Row + 対象行 - 1, Range("a3").Column).Select MsgBox "選択した行に重複があるので終了します" Exit Sub Else If 表配列(対象行, 2) <> "" And 表配列(対象行, 3) <> "" Then 辞書(キー) = Array(表配列(対象行, 2),表配列(対象行, 3)) End If End If Next Erase 表配列 '転記先 シートの選択 Sheets("Sheet1").Select '対象を配列に入れる Dim 対象配列() As Variant, 最終行2 As Long 最終行2 = Cells(Rows.Count, Range("e3").Column).Offset(0,1-1).End(xlUp).Row 対象配列 = Range("e3" & ":" & Cells(最終行2, Range("g3").Column).Address(False, False)).Value '対象配列に辞書のアイテムを入れる Dim 行 As Long For 行 = 1 To UBound(対象配列, 1) キー = 対象配列(行,1) If 辞書.Exists((キー)) Then 対象配列(行, 2) = 辞書(キー)(0) 対象配列(行, 3) = 辞書(キー)(1) End If Next 行 '対象配列をシートに反映する Sheets("Sheet1").Range("e3").Resize(UBound(対象配列), UBound(対象配列, 2)).Value = 対象配列 'Application.ScreenUpdatingとApplication.DisplayAlertsをTrueに戻す Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub
コードの赤い部分が追加されました。
ChatGPTで修正したコードを、VBE画面に貼り付ければ、マクロの完成です。😄