枠組み

---

マクロ実行ファイルから、新たにエクセルファイルを生成しコントロールする

sub main()
    Dim rc As Integer
    rc = MsgBox("実行してもよろしいですか？", vbYesNo + vbQuestion, "確認")
    If rc = vbNo Then
        Exit Sub
    End If
    ' 変数の宣言...
    Dim SavePath, fName, sName, dName, st, StNo, StName, ts As String
    Dim pMaxRow, cMaxRow As Integer
    Dim MaxCol As Integer
    Dim I, J, K, ItemNo As Integer
    Dim meFileName As String
    Dim host1 As Window
    '自分自身のファイル名...
    meFileName = ThisWorkbook.Name
    Set host1 = Application.Windows(meFileName)
    SavePath = ActiveWorkbook.Path & "\"
    
    dName = "source_sheet"
    fName = "dest_file.xlsx"
   
    If Dir(SavePath & fName) <> "" Then
        rc = MsgBox("既にファイルがあります。既にあるファイルを削除して新たに作成しますか？", vbYesNo + vbQuestion)
        If rc = vbNo Then
            MsgBox "処理を中止します", vbCritical
            Exit Sub
        Else
            'ファイルを削除する...
            Kill SavePath & fName
        End If
    End If
    host1.Activate
    '新規にブックを作成
    Workbooks.Add
    ActiveWorkbook.SaveAs Filename := SavePath & fName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    'シートのコピー実施
    host1.Activate
    Sheets(dName).Visible = True
    Sheets(dName).Select
    Sheets(dName).Copy After:=Workbooks(fName_1).Sheets(1)
    'シート名を局名とする
    Windows(fName).Activate
    Sheets(dName).Name = dName
    '行のデータ数分だけ回す
    host1.Activate
    pMaxRow = Sheets("ABC").Range("A1").End(xlDown).Row
    For I = 0 To pMaxRow
        ' 処理の記載...
    Next I
    'データの無いシートを削除
    del_sheets (fName)
    Windows(fName).Activate
    Sheets(1).Select
    ActiveWorkbook.Save
    MsgBox "処理が終了しました。"
End Sub

'空白のシートを削除する
Sub del_sheets(ByVal host As String)
  Dim I As Long
  Windows(host).Activate
  Application.DisplayAlerts = False
  For I = Worksheets.Count To 1 Step -1
    If WorksheetFunction.CountA(Worksheets(I).UsedRange) = 0 Then
        If Worksheets.Count > 1 Then Worksheets(I).Delete
    End If
  Next I
  Application.DisplayAlerts = True
End Sub



            

---