| |
▼SS さん：
ありがとうございます。早速コード使わせていただきました。
私が書いたのよりずっと早くて快適なのですが、私の説明が下手だったのかうまくいかないところがありましたので、どこがおかしいかご指導よろしくお願いします。
お示しのコードを参考に以下のように書きました
Private Sub CommandButton17_Click()
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
Dim Dic As Variant, WS As Variant
Set xlAPP = Application
Set WBK1 = ThisWorkbook
Set Dic = CreateObject("Scripting.Dictionary")
tblSH = Array("あいう", "あいうえ", "あいうえお", _
"かきく", "かきくけ", "かきくけこ", _
"さしす", "さしすせ", "さしすせそ")
・・・問題（1）
xlAPP.StatusBar = "出力するファイル名を指定して下さい。"
strFILENAME = xlAPP.GetSaveAsFilename(InitialFileName:="データ年度.xls", _
FileFilter:=cnsFILTER, Title:=cnsTITLE)
If StrConv(strFILENAME, vbUpperCase) = "FALSE" Then Exit Sub
If strFILENAME = WBK1.FullName Then
MsgBox "本ブックとは違うファイル名を指定して下さい。", , cnsTITLE
GoTo MAKE_NEWBOOK_WO_MACROS_EXIT
End If
Set WBK2 = ActiveWorkbook
For i = 1 To UBound(tblSH)
For j = 1 To 12
Dic.Add tblSH(i) & j & "月", 1
Next j
Next i
'ワークシートの名前確認
For Each WS In WBK1.Sheets
If Dic.Exists(WS.Name) Then
WS.Copy After:=WBK2.Sheets(Sheets.Count)
End If
Next WS
Set Dic = Nothing
For Each objVBCOMPO In WBK2.VBProject.VBComponents
With objVBCOMPO.CodeModule
lngLines = .CountOfLines
If lngLines <> 0 Then .DeleteLines 1, lngLines
End With
Next objVBCOMPO
Dim sh As Worksheet
For Each sh In WBK2.Worksheets
For Each objAS In sh.Shapes
objAS.Delete
Next
Next
WBK2.SaveAs Filename:=strFILENAME
WBK2.Close False
Set WBK2 = Nothing
MAKE_NEWBOOK_WO_MACROS_EXIT:
Set WBK1 = Nothing
Set xlAPP = Nothing
Unload Me
End Sub
問題（1） 後ろに1〜12月を付けたいシート（さしすせそ）と、コピーしたいシート（さしすせそ以外）のみ書きましたが全シートコピーされてしまう。
問題（2） 新しく作られたブックを立ち上げると、データのみのはずなのにﾏｸﾛの警告が出る
問題（3) 新しいブックが保存されて落ちると、本ブックまで落ちる（保存はされません）
以上です。よろしくお願いします。
|
|
かかこ
- 11/10/19(水) 15:57 -
