| |
▼かかこ さん：
作ってみました。自分勝手に弄っていますので参考程度にみて下さい。
先ずは問題への対応から
>問題（1） 後ろに1〜12月を付けたいシート（さしすせそ）と、コピーしたいシート（さしすせそ以外）のみ書きましたが全シートコピーされてしまう。
コピーするワークシート名のルールを勘違いしていました。
記述を省力化したいのかなと考えていました。
規則性がないようでしたら全て配列に収めてしまった方が良いと思います。
>問題（2） 新しく作られたブックを立ち上げると、データのみのはずなのにﾏｸﾛの警告が出る
自ファイルを名前を付けて保存しているのでマクロが入っています。
>問題（3) 新しいブックが保存されて落ちると、本ブックまで落ちる（保存はされません）
上の問題と一緒で本ブックはその前に落ちています。
あとOption Explicitはデフォールトにした方が良いですよ。
Sub test()
Const cnsTITLE = "マクロなしブックの作成"
Const cnsFILTER = "Excelワークブック (*.xls),*.xls"
Dim xlAPP As Application
Dim WBK1 As Workbook
Dim WBK2 As Workbook
Dim objVBCOMPO As Object
Dim strFILENAME As String
Dim lngLines As Long
Dim i As Integer, j As Integer, Temp As Integer
Dim tblSH As Variant
Dim SN As Variant, WS As Variant
Dim sh As Worksheet
Dim objAS As Object
Set xlAPP = Application
Set WBK1 = ThisWorkbook
tblSH = Array("あいう", "あいうえ", "あいうえお", _
"かきく", "かきくけ", "かきくけこ", _
"さしす", "さしすせ", "さしすせそ", _
"さしすせそ4月", "さしすせそ6月", _
"さしすせそ7月", "さしすせそ10月")
xlAPP.StatusBar = "出力するファイル名を指定して下さい。"
strFILENAME = xlAPP.GetSaveAsFilename(InitialFileName:="データ年度.xls", _
FileFilter:=cnsFILTER, Title:=cnsTITLE)
If StrConv(strFILENAME, vbUpperCase) = "FALSE" Then
Exit Sub
ElseIf strFILENAME = WBK1.FullName Then
MsgBox "本ブックとは違うファイル名を指定して下さい。", , cnsTITLE
GoTo MAKE_NEWBOOK_WO_MACROS_EXIT
Else
'Sheet1のみのWorkbookをつくり前述名前をつけます。
Temp = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Workbooks.Add
Application.SheetsInNewWorkbook = Temp
ActiveWorkbook.SaveAs Filename:=strFILENAME
Set WBK2 = ActiveWorkbook
End If
'ワークシートの名前確認
'配列を一度Dicに入れた方が良いのかは分かりません。
For Each WS In WBK1.Sheets
For Each SN In tblSH
If SN = WS.Name Then
WS.Copy After:=WBK2.Sheets(Sheets.Count)
Exit For
End If
Next SN
Next WS
'Sheet1以外にSheetがある場合Sheet1を削除します。
'もしSheet1が必要なら消してください。
'確認したい場合はApplication.DisplayAlerts関連を消してください。
If WBK2.Sheets.Count > 1 Then
Application.DisplayAlerts = False
WBK2.Worksheets("Sheet1").Delete
Application.DisplayAlerts = True
End If
For Each sh In WBK2.Worksheets
For Each objAS In sh.Shapes
objAS.Delete
Next
Next
WBK2.Close
Set WBK2 = Nothing
Exit Sub
MAKE_NEWBOOK_WO_MACROS_EXIT:
Set WBK1 = Nothing
Set xlAPP = Nothing
End Sub
|
|
SS
- 11/10/19(水) 19:32 -
