ExcelVBAロボット。決定を補助してくれるデータをもってきて！
前回は、ファイルやシートをコピーについて行いました。
考えながらする時は手作業が良いと思います。でも、定型的に繰り返すことはロボットにお願いしたいと個人的には思っています。
作業全体の流れのなかで
取引先へ贈答した、お中元、お歳暮のリストの過去のものがずらっと並んだ贈答品.xlsxがあります。新シート、今回だと[2022お歳暮]のシートを作り⇒「今年のお歳暮どうするか考え、決めて」⇒リスト仕上げ、注文書を作ります。
仕事としてはここが肝心なところで、考えをまとめる、その検討を補助してくれる、過去のデータ一覧を作ります。
１．エクセルをこうして
(D)はシート名で検索します →「どこに送る？」検討
前回（この場合2022お中元）と同じところに送れば良いかと考えますが、昨年2021お歳暮や、できればその前あたりも見て、有り無しなど確認して（前回も間違いないんでしょうけど、今回以降は自分の責任になるので）安心したいところです。
(E)は取引先名で検索します →「何を送る？」検討
無難なもので良いかと考えますが、取引先によって、まったく同じなのか、お中元・お歳暮でパターンあるのか、金額を確認したいところです。
２．コードをコピペ、ボタンを設定
Sub シート名検索() 'ボタン4に設定
Application.ScreenUpdating = False 'スクリーンOFF
Sheets("Sheet1").Select 'シートの選択
'前に書き出した一覧表クリア
kaisi_gyo = 21
maxRow = Range("B65536").End(xlUp).Row
If maxRow >= kaisi_gyo Then
Range(Cells(21, 2), Cells(maxRow, 8)).Select
Selection.ClearContents
End If
Range("C13").Select
'このエクセルファイル名
a_name = ActiveWorkbook.Name
'ターゲットのフォルダ名とファイル名
pt = Range("C5") 'フォルダ名
fn = Range("D5") & Range("E5") 'ファイル名
t_fll = pt & "\" & fn 'ファイル名（フルパス）
'今回のシート名
new_sheet = Range("C10")
'検索文字★
word_s = Range("C13")
'検索開始行・書き出し開始行
gyo1 = 3
gyo2 = kaisi_gyo
'変数
t_name = ""
sina = ""
kin = 0
saki = ""
t_ad = ""
tel = ""
'ターゲットファイルが開いていたら閉じる()
On Error Resume Next
Open t_fll For Append As #1
Close #1
If Err.Number > 0 Then
Workbooks(fn).Activate
ActiveWorkbook.Close
Application.CutCopyMode = True
End If
'ターゲットファイルを開く
Workbooks.Open Filename:=t_fll
'ターゲットのシートを順に読む
On Error Resume Next
For Each sheet_name In Worksheets
If sheet_name.Name <> "注文書1" Then '---------------------------1
If sheet_name.Name <> "注文書2" Then '-------------------------2
If sheet_name.Name <> new_sheet Then '---------------------3
If InStr(sheet_name.Name, word_s) > 0 Then '★----------4
Sheets(sheet_name.Name).Select
Do While Cells(gyo1, 1) <> ""
t_name = Cells(gyo1, 1)
sina = Cells(gyo1, 2)
kin = Cells(gyo1, 3)
saki = Cells(gyo1, 4)
t_ad = Cells(gyo1, 5)
tel = Cells(gyo1, 6)
Workbooks(a_name).Activate
Cells(gyo2, 2) = sheet_name.Name
Cells(gyo2, 3) = t_name
Cells(gyo2, 4) = sina
Cells(gyo2, 5) = kin
Cells(gyo2, 6) = saki
Cells(gyo2, 7) = t_ad
Cells(gyo2, 8) = tel
gyo2 = gyo2 + 1
Workbooks(fn).Activate
gyo1 = gyo1 + 1
Loop
End If '★---------------------------------------------4
End If '---------------------------------------------------3
End If '-------------------------------------------------------2
End If '---------------------------------------------------------1
gyo1 = 3
Next
'ターゲットファイルを閉じる
Dim wb As Workbook
For Each wb In Workbooks
If wb.Name = fn Then
Application.CutCopyMode = False
wb.Close SaveChanges:=False
Application.CutCopyMode = True
End If
Next
'シート名でソート
maxRow = Range("B65536").End(xlUp).Row
Range(Cells(20, 2), Cells(maxRow, 8)).Sort _
Key1:=Range("B20"), _
Order1:=xlDescending, _
Header:=xlYes
Application.ScreenUpdating = True 'スクリーンON
End Sub
Sub 相手先検索() 'ボタン5に設定
Application.ScreenUpdating = False 'スクリーンOFF
Sheets("Sheet1").Select 'シートの選択
'前に書き出した一覧表クリア
kaisi_gyo = 21
maxRow = Range("B65536").End(xlUp).Row
If maxRow >= kaisi_gyo Then
Range(Cells(kaisi_gyo, 2), Cells(maxRow, 8)).Select
Selection.ClearContents
End If
Range("G13").Select
'このエクセルファイル名
a_name = ActiveWorkbook.Name
'ターゲットのフォルダ名とファイル名
pt = Range("C5") 'フォルダ名
fn = Range("D5") & Range("E5") 'ファイル名
t_fll = pt & "\" & fn 'ファイル名（フルパス）
'今回のシート名
new_sheet = Range("C10")
'検索文字★
word_s = Range("G13")
'検索開始行・書き出し開始行
gyo1 = 3
gyo2 = kaisi_gyo
'変数
t_name = ""
sina = ""
kin = 0
saki = ""
t_ad = ""
tel = ""
'ターゲットファイルが開いていたら閉じる()
On Error Resume Next
Open t_fll For Append As #1
Close #1
If Err.Number > 0 Then
Workbooks(fn).Activate
ActiveWorkbook.Close
Application.CutCopyMode = True
End If
'ターゲットファイルを開く
Workbooks.Open Filename:=t_fll
'ターゲットのシートを順に読む
On Error Resume Next
For Each sheet_name In Worksheets
If sheet_name.Name <> "注文書1" Then '---------------------------1
If sheet_name.Name <> "注文書2" Then '-------------------------2
If sheet_name.Name <> new_sheet Then '---------------------3
Sheets(sheet_name.Name).Select
Do While Cells(gyo1, 1) <> ""
If InStr(Cells(gyo1, 1), word_s) > 0 Then '★------4
t_name = Cells(gyo1, 1)
sina = Cells(gyo1, 2)
kin = Cells(gyo1, 3)
saki = Cells(gyo1, 4)
t_ad = Cells(gyo1, 5)
tel = Cells(gyo1, 6)
Workbooks(a_name).Activate
Cells(gyo2, 2) = sheet_name.Name
Cells(gyo2, 3) = t_name
Cells(gyo2, 4) = sina
Cells(gyo2, 5) = kin
Cells(gyo2, 6) = saki
Cells(gyo2, 7) = t_ad
Cells(gyo2, 8) = tel
gyo2 = gyo2 + 1
Workbooks(fn).Activate
End If '★-----------------------------------------4
gyo1 = gyo1 + 1
Loop
End If '---------------------------------------------------3
End If '-------------------------------------------------------2
End If '---------------------------------------------------------1
gyo1 = 3
Next
'ターゲットファイルを閉じる
Dim wb As Workbook
For Each wb In Workbooks
If wb.Name = fn Then
Application.CutCopyMode = False
wb.Close SaveChanges:=False
Application.CutCopyMode = True
End If
Next
'シート名でソート
maxRow = Range("B65536").End(xlUp).Row
Range(Cells(20, 2), Cells(maxRow, 8)).Sort _
Key1:=Range("B20"), _
Order1:=xlDescending, _
Header:=xlYes
Application.ScreenUpdating = True 'スクリーンON
End Sub
次回は、ズラッと並んで・・からの脱出の最終回！
リストづくりと、発注書への書き換えをします。
不明点は、ご連絡いただいて結構です。
（すぐにとか、直接）お答えできないときはすみません。
note初心者なんで、noteのコミュニケートの方法よく分かりませんが ^^；
Twitterでも。どのツイートでも返信に「noteを見た」で良いです。
出来高急増！
この記事が気に入ったらサポートをしてみませんか？