【困っています】VBA 追加処理の記述を教えてください。 削除
| Message#1 2022年8月25日(木)23時39分 From: 鈴木太郎 |
| VBA 追加処理の記述を教えてください。 お世話になります。マクロの初心者です、稚拙な部分はご容赦ください。 下記マクロを実行すると、元データが複数のファイルに分割されます。 追加作業としては、@シートの保護 出来上がった全ファイルのシートは１つ(シート名：『Sheet1』のみ)のA列〜H列とJ列は保護され『I列』と『K列』は 保護されない(PWは、【9753】)。かつオートフィルタ設定でオートフィルタの操作は可能。 Aファイルの種類は、CSVでファイルを作成希望。 自動で作成したく(今は手動で毎週100件作成)、ご教示の程お願い致します。 下記に対象リンク先と記述を記します。 リンク先 https://www.helpforest.com/excel/emv_sample/ex100010.htm ----------------------------------------------------------------------------------- SubSample() DimMacroBAsWorksheet'このブックのシート DimWb_DataAsWorkbook'1.分割元ブック DimWb_newAsWorkbook'分割データ保存ブック DimWsAsString'2.分割元シート名 DimPathAsString'3.分割データ保存先 DimC_GroupAsString'4.グループ対象列 DimGroupNameAsString'グループ名（ブック名） DimC_CopyAsString'5.コピーデータ右端列 DimYMDAsString'6.保存ブック日付の表示形式 DimPSWAsString'7.読み取りパスワード DimR_DataAsInteger'データの行番号 DimKoAsInteger'グループの件数 SetMacroB=ThisWorkbook.Worksheets(1)'このブックのシート SetWb_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") IfYMD=""Then YMD="" Else YMD=Format(Date,YMD) EndIf 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.PasteRange("A1")'新規ブックに貼り付け SetWb_new=ActiveWorkbook Wb_Data.Activate GroupName=Cells(R_Data,C_Group) Ko=WorksheetFunction.CountIf(Columns(C_Group),GroupName)'グループの件数を算出 Range(Cells(R_Data,"A"),Cells(R_Data+Ko-1,C_Copy)).Copy'グループ件数分コピー Wb_new.Activate ActiveSheet.PasteRange("A2")'新規ブック項目の下に貼り付け ActiveSheet.Columns.AutoFit ActiveSheet.UsedRange.Borders.LineStyle=True Range("D2").Select ActiveWindow.FreezePanes=True DimmynameAsString'条件不明 IfActiveSheet.Range("A2")<>""Then myname=ActiveSheet.Range("A2") EndIf Wb_new.SaveAsFilename:=Path&GroupName&"注残納期回答依頼リスト"&YMD&".xlsx",_ Password:=PSW'指定したフォルダーに保存 Wb_new.Close R_Data=R_Data+Ko LoopWhileCells(R_Data,C_Group)<>"" MsgBox"完了！" Application.ScreenUpdating=True EndSub |
上のメッセージを削除します。
よければパスワードを入力し、削除ボタンをクリックしてください。
