【VBA】ブックを開く/ブックを保存する
<機能>
(1)新規ブックを作成し保存します
シート数を指定して新規ブックを作成します
シート名を変更します
(2)ブックを開きます
(3)ブックを編集後、保存します
上書き保存
名前を付けて保存(サンプル掲載)
名前を付けてパスワード付きで保存(サンプル掲載)
Webページとして保存(サンプル掲載)
ダイアログボックス(Dialogs)で保存(サンプル掲載)
<使い方>
適当なところにソースを張り付けてください
ブックの新規作成と保存()を呼び出すとブックの操作を行います
新規ブック作成
→新規ブックを保存
→ブックを開く
→ブックを編集
→上書き保存(他サンプルあり)
<イメージ>
ブックを新規作成する際のシート数は オプション > 基本設定 > ブックのシート数(S) に設定されていますが一時的に変更します
サンプルデータを設定してブックを保存します
'********************************************
'ブックの読み込みと保存
' (1)テスト用のブックを生成(ブック名年月日時分秒)
' (2)テスト用のブックを読み込み後、別名で保存
'********************************************
Sub ブックの新規作成と保存()
Dim strName As String
'ブックの読み込みと保存
' (1)テスト用のブックを生成(ブック名年月日時分秒)
' (2)テスト用のブックを読み込み後、別名で保存
'********************************************
Sub ブックの新規作成と保存()
Dim strName As String
'//ブック名を生成
strName = ThisWorkbook.Path & "¥SAMPLE_" & Replace(Replace(Replace(Now(), "/", ""), " ", ""), ":", "") & ".xlsx"
'//ブックを作成
新規ブックを作成する strName
strName = ThisWorkbook.Path & "¥SAMPLE_" & Replace(Replace(Replace(Now(), "/", ""), " ", ""), ":", "") & ".xlsx"
'//ブックを作成
新規ブックを作成する strName
'//ブックを編集(先頭シートを編集)して上書き保存
ブックを編集して保存 strName
End Sub
ブックを編集して保存 strName
End Sub
'********************************************
'新規ブックを作成する
' (1)シート数を指定
' (2)シート名を変更
'********************************************
Sub 新規ブックを作成する(ByVal strBook As String)
Dim wkSheetcnt As Integer
Dim wkstr As String
Dim i As Integer
'新規ブックを作成する
' (1)シート数を指定
' (2)シート名を変更
'********************************************
Sub 新規ブックを作成する(ByVal strBook As String)
Dim wkSheetcnt As Integer
Dim wkstr As String
Dim i As Integer
'//オプション > 基本設定 > ブックのシート数(S) の設定値を保持
wkSheetcnt = Application.SheetsInNewWorkbook
wkSheetcnt = Application.SheetsInNewWorkbook
'//一時的に オプション > 基本設定 > ブックのシート数(S) の設定値を変更
Application.SheetsInNewWorkbook = 10
'//ブックを新規作成(シート数は10)
Workbooks.Add
Application.SheetsInNewWorkbook = 10
'//ブックを新規作成(シート数は10)
Workbooks.Add
'//オプション > 基本設定 > ブックのシート数(S) の設定値をもとに戻す
Application.SheetsInNewWorkbook = wkSheetcnt
Application.SheetsInNewWorkbook = wkSheetcnt
'//シート名変更
'//"Sheet" + シート番号(2桁固定)
For i = 1 To ActiveWorkbook.Sheets.Count
wkstr = Format(i, "00")
ActiveWorkbook.Sheets(i).Name = "Sheet" & wkstr
Next
'//"Sheet" + シート番号(2桁固定)
For i = 1 To ActiveWorkbook.Sheets.Count
wkstr = Format(i, "00")
ActiveWorkbook.Sheets(i).Name = "Sheet" & wkstr
Next
'//ブックを保存して閉じる
'//FileFormatにExcelブック(*.xlsx)形式を指定
'//XlFileFormat列挙体の設定値についてはMSDN参照
ActiveWorkbook.SaveAs Filename:=strBook, FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close
End Sub
'//FileFormatにExcelブック(*.xlsx)形式を指定
'//XlFileFormat列挙体の設定値についてはMSDN参照
ActiveWorkbook.SaveAs Filename:=strBook, FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close
End Sub
'********************************************
'ブックを開いて編集後に保存
' (1)先頭シートを編集
' (2)ブックを保存
'********************************************
Sub ブックを編集して保存(ByVal strBook As String)
Dim ipos As Integer
Dim wkstr As String
'ブックを開いて編集後に保存
' (1)先頭シートを編集
' (2)ブックを保存
'********************************************
Sub ブックを編集して保存(ByVal strBook As String)
Dim ipos As Integer
Dim wkstr As String
'//ブックを開く
Workbooks.Open strBook
'//先頭シートを編集のためアクティブにする
ipos = InStrRev(strBook, "¥")
If ipos > 0 Then
strfil = Right(strBook, Len(strBook) - ipos)
Else
MsgBox "ファイルパスが不正なため処理を中止します" & vbCrLf & strBook, vbCritical
Exit Sub
End If
Workbooks(strfil).Activate
Sheets(1).Activate
Workbooks.Open strBook
'//先頭シートを編集のためアクティブにする
ipos = InStrRev(strBook, "¥")
If ipos > 0 Then
strfil = Right(strBook, Len(strBook) - ipos)
Else
MsgBox "ファイルパスが不正なため処理を中止します" & vbCrLf & strBook, vbCritical
Exit Sub
End If
Workbooks(strfil).Activate
Sheets(1).Activate
'//先頭シートに書式を設定
Columns("A").ColumnWidth = 7
Columns("B:D").ColumnWidth = 35
Columns("A:D").Font.Name = "MS ゴシック"
Columns("A:D").Font.Size = 12
With Range("A1:D3").Borders
.Weight = xlThin
End With
With Range("A1:D1")
.Interior.ColorIndex = 45
.Font.ColorIndex = 35
End With
'//先頭シートにサンプルデータをセット
Cells(1, 1) = "コード"
Cells(1, 2) = "支店名"
Cells(1, 3) = "住所"
Cells(1, 4) = "電話番号"
Columns("A").ColumnWidth = 7
Columns("B:D").ColumnWidth = 35
Columns("A:D").Font.Name = "MS ゴシック"
Columns("A:D").Font.Size = 12
With Range("A1:D3").Borders
.Weight = xlThin
End With
With Range("A1:D1")
.Interior.ColorIndex = 45
.Font.ColorIndex = 35
End With
'//先頭シートにサンプルデータをセット
Cells(1, 1) = "コード"
Cells(1, 2) = "支店名"
Cells(1, 3) = "住所"
Cells(1, 4) = "電話番号"
Cells(2, 1) = "A001"
Cells(2, 2) = "新宿駅前支店"
Cells(2, 3) = "東京都新宿区新宿1−2−3"
Cells(2, 4) = "03-1234-5678"
Cells(2, 2) = "新宿駅前支店"
Cells(2, 3) = "東京都新宿区新宿1−2−3"
Cells(2, 4) = "03-1234-5678"
Cells(3, 1) = "A002"
Cells(3, 2) = "横浜支店"
Cells(3, 3) = "神奈川県横浜市中区桜木町 1−2−3"
Cells(3, 4) = "045-123-4567"
Cells(3, 2) = "横浜支店"
Cells(3, 3) = "神奈川県横浜市中区桜木町 1−2−3"
Cells(3, 4) = "045-123-4567"
'//確認メッセージを表示しない
Application.DisplayAlerts = False
Application.DisplayAlerts = False
'//ブックを上書き保存して閉じる
Workbooks(strfil).Save
Workbooks(strfil).Save
'//名前を付けて保存する場合
'Workbooks(strfil).SaveAs Filename:="SampleBook.xlsx"
'Workbooks("SampleBook.xlsx").close
'Workbooks(strfil).SaveAs Filename:="SampleBook.xlsx"
'Workbooks("SampleBook.xlsx").close
'//名前を付けてパスワード付きで保存する場合
'Workbooks(strfil).SaveAs Filename:="SampleBook.xlsx", Password:="abcde"
'Workbooks("SampleBook.xlsx").Close
'Workbooks(strfil).SaveAs Filename:="SampleBook.xlsx", Password:="abcde"
'Workbooks("SampleBook.xlsx").Close
'//Webページとして保存する場合
'Workbooks(strfil).SaveAs Filename:="SampleBook.html", FileFormat:=xlHtml
'Workbooks("SampleBook.html").Close
'Workbooks(strfil).SaveAs Filename:="SampleBook.html", FileFormat:=xlHtml
'Workbooks("SampleBook.html").Close
'//ダイアログボックスで保存する場合
'Dim bSave As Boolean
'bSave = Application.Dialogs(xlDialogSaveAs).Show
'If bSave Then
' Debug.Print "保存されました"
'End If
'Dim bSave As Boolean
'bSave = Application.Dialogs(xlDialogSaveAs).Show
'If bSave Then
' Debug.Print "保存されました"
'End If
'//元のブックがまだ開いていれば閉じる
Dim wkbk As Workbook
For Each wkbk In Workbooks
If wkbk.Name = strfil Then
Workbooks(strfil).Close
GoTo alerts_true
End If
Next wkbk
Dim wkbk As Workbook
For Each wkbk In Workbooks
If wkbk.Name = strfil Then
Workbooks(strfil).Close
GoTo alerts_true
End If
Next wkbk
alerts_true:
Application.DisplayAlerts = True
End Sub
Application.DisplayAlerts = True
End Sub
よろしければポチッと押してください