【前回の続きです、ご教示ください】VBAの記述方法がわかりません。

お世話になります。
前回20220812 2128に投稿させていただき、回答をいただきトライしましたがうまくいきませんでした。私の情報が足らないか、理解できていない部分があるかもしれません。再度投稿させていただきます。どなたかご教示いただけませんでしょうか。(出来ればQchan1962様に続きをお願いします。)
●最初の質問は、下記のマクロ記述に変更を加えて、追加の作業を行いたいのですが、詳細は下記①の文面と添付ファイルの左半分をご覧ください。下記の②は頂いた回答です(添付ファイル左半分の文面の①～③作業部分を抜粋)、
●追加の質問は、添付ファイルの右半分は頂いた回答で実行した結果のエラーメッセージです。の修正方法です。
どうぞよろしくお願いいたします。
------------------------------------------------------------
①
Sub Sample()
Dim MacroB As Worksheet 'このブックのシート
Dim Wb_Data As Workbook '1. 分割元ブック
Dim Wb_new As Workbook '分割データ保存ブック
Dim Ws As String '2. 分割元シート名
Dim Path As String '3. 分割データ保存先
Dim C_Group As String '4. グループ対象列
Dim C_Copy As String '5. コピーデータ右端列
Dim YMD As String '6. 保存ブック日付の表示形式
Dim PSW As String '7. 読み取りパスワード
Dim R_Data As Integer 'データの行番号
Dim Ko As Integer 'グループの件数
Set MacroB = Workbooks("ex100010.xlsm").Worksheets(1) 'このブックのシート
Set Wb_Data = Workbooks(MacroB.Range("C11").Value) '分割元のブック名
Ws = MacroB.Range("C12")
Path = MacroB.Range("C13") & "¥"
C_Group = MacroB.Range("C14")
C_Copy = MacroB.Range("C15")
YMD = MacroB.Range("C16")
PSW = MacroB.Range("C17")
If YMD = "" Then
YMD = ""
Else
YMD = Format(Date, YMD)
End If
R_Data = 2 'データの開始行
Application.ScreenUpdating = False
Do
Wb_Data.Activate
Worksheets(Ws).Range(Cells(1, 1), Cells(1, C_Copy)).Copy '1行目の項目名コピー
Workbooks.Add
ActiveSheet.Paste Range("A1") '新規ブックに貼り付け
Set Wb_new = ActiveWorkbook
Wb_Data.Activate
Ko = WorksheetFunction.CountIf(Columns(C_Group), Cells(R_Data, C_Group)) 'グループの件数を算出
Range(Cells(R_Data, "A"), Cells(R_Data + Ko - 1, C_Copy)).Copy 'グループ件数分コピー
Wb_new.Activate
ActiveSheet.Paste Range("A2") '新規ブック項目の下に貼り付け
Wb_new.SaveAs Filename:=Path & Cells(2, C_Group) & YMD & ".xlsx", _
Password:=PSW '指定したフォルダーに保存
Wb_new.Close
R_Data = R_Data + Ko
Loop While Cells(R_Data, C_Group) <> ""
MsgBox "完了！"
Application.ScreenUpdating = True
End Sub
------------------------------------------------------------
②頂いた回答(添付ファイルAの文面の①～③作業部分を抜粋)
ActiveSheet.Paste Range("A2") '新規ブック項目の下に貼り付け
'①
ActiveSheet.Columns.AutoFit
'②
ActiveSheet.UsedRange.Borders.LineStyle = True
'③
Dim myname As String　'条件不明
If ActiveSheet.Range("A2") <> "" Then
myname = ActiveSheet.Range("A2")

End If

No.2 ベストアンサー 回答者： Qchan1962 回答日時： 2022/08/16 20:04

こんばんは、本ご質問は見えませんので取り合えず

先の　https://oshiete.goo.ne.jp/qa/13091795.html　回答をコードに入れてみました
参照設定については　https://tonari-it.com/vba-outlook-object/　を確認してください
文字数制限がある為、Wb_new.Activate　以下の部分です
ご質問を取り違えている可能性もありますので確認してみてください

Wb_new.Activate
ActiveSheet.Paste Range("A2") '新規ブック項目の下に貼り付け
'①
ActiveSheet.Columns.AutoFit
'②
ActiveSheet.UsedRange.Borders.LineStyle = True
'③
Dim myname As String 'A2かA5 条件不明
If ActiveSheet.Range("A2") <> "" Then
myname = ActiveSheet.Range("A2").Text
Else
myname = ActiveSheet.Range("A5").Text
End If
'ファイル名の頭につける　Cells(2, C_Group) がファイル名か不明
Wb_new.SaveAs Filename:=Path & "\" & myname & Cells(2, C_Group) & YMD & ".xlsx", _
Password:=PSW '指定したフォルダーに保存
Wb_new.Close

'④は　メールOutlookのコードがないので不明　サブで処理
'ループするのでここで良いのか不明？Loopを抜けた場所？
Call my_Outlook(myname & Cells(2, C_Group) & YMD)

R_Data = R_Data + Ko
Loop While Cells(R_Data, C_Group) <> ""

MsgBox "完了！"
Application.ScreenUpdating = True
End Sub

Sub my_Outlook(mySubject As String)
'要　Outlook参照設定
'メール件名にファイル名を設定
Dim oApp As New Outlook.Application
Dim oItem As Outlook.MailItem
Set oItem = oApp.CreateItem(olMailItem)
With oItem
.Subject = mySubject
.Display
End With
Set oItem = Nothing
Set oApp = Nothing
End Sub

エラーがある場合、箇所（コード）とエラー番号を教えてください

帰宅、その他の為、遅くになります

この回答へのお礼

Qchan1962様
お世話になります。ご連絡が遅くなり大変申し訳ありませんでした。
上手くいきました。
本日使用環境を変えてトライしました。
メールのけんは来週確認します。
お時間いただけましたら、よろしくお願いします。
有り難うございました。

お礼日時：2022/08/19 19:51

No.1 回答者： 初心者ですが何か。 回答日時： 2022/08/16 19:03

直接の回答ではなく申し訳ないですが、ここでの画像添付には限度もあります。

仮に過去の質問が関連し且つ画像が見やすい（回答を得られたのなら多分そうかなと）のなら、その質問のリンクを貼った方が宜しかったかと。

または
https://oshiete.goo.ne.jp/qa/12976211.html
こちらの＃１回答者さんの方法を参考にされるなど。

この回答へのお礼

初心者ですが何か。様
ご連絡有り難うございます。
おっしゃる通りでした。次回より参考にさせていただきます。
温かいアドバイスを有り難うございました。
失礼します。

お礼日時：2022/08/16 23:00