| |
とりあえず、下記の通りにコードを追加してみたら
うまくいきました！有難う御座いました。
CutCopyModeは入れた方がいいのでしょうか。
Private Sub タグ作成_Click()
Dim InPt As Long
Dim c As Object
Dim myKey As String
Dim SaveName As String
Dim wb As Workbook, wkbk As Workbook
Set wb = ThisWorkbook
InPt = Application.InputBox(prompt:="No.を入力して下さい。", Type:=1)
If InPt = False Then Exit Sub
Application.ScreenUpdating = False
ActiveSheet.Unprotect
myKey = InPt
With ActiveSheet.Range("$c$5:$c$3000")
Set c = .Find(What:=myKey, LookIn:=xlValues, lookat:=xlWhole, _
SearchOrder:=xlByColumns, MatchByte:=False)
If c Is Nothing Then
MsgBox "No." & InPt & "は登録されていません。"
Else
ThisWorkbook.Sheets("タグ").Visible = True
Sheets("タグ").Activate
With wb.ActiveSheet
.Range("c3").Value = InPt
.Range("B2:C16").Copy
End With
Application.EnableEvents = False
Set wkbk = Workbooks.Add
With wkbk.ActiveSheet
.Range("B2").PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Range("B2").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Columns("A:A").ColumnWidth = 0.5
.Columns("B:B").ColumnWidth = 10
.Columns("C:C").ColumnWidth = 50
.Columns("d:d").ColumnWidth = 0.5
.Rows("1:1").RowHeight = 5
.Rows("17:17").RowHeight = 5
.Columns("E:IV").EntireColumn.Hidden = True
.Rows("18:65536").EntireRow.Hidden = True
End With
With ActiveWindow
.DisplayGridlines = False
.DisplayHeadings = False
.DisplayOutline = False
.DisplayZeros = False
.DisplayHorizontalScrollBar = False
.DisplayVerticalScrollBar = False
.DisplayWorkbookTabs = False
End With
SaveName = "C:\Documents and Settings\123\デスクトップ\" & InPt & "タグ.xls"
Application.DisplayAlerts = False
ActiveSheet.Range("c3").Locked = True
ActiveSheet.Protect password:="1234"
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ActiveWorkbook.SaveAs Filename:=SaveName, FileFormat:=xlNormal, password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
wkbk.Close False
Sheets("タグ").Activate
ThisWorkbook.Activesheet.Range("C3").ClearContents
ThisWorkbook.Sheets("タグ").Visible = xlSheetVeryHidden
Sheets("台帳").Activate
MsgBox "タグ作成しました。"
Set wb = Nothing
Set wkbk = Nothing
Application.EnableEvents = True
End If
End With
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
▼らいち さん：
>nさん、ご丁寧な説明を頂き、ありがとうございます。
>全くの初心者で申し訳ありません。ご指摘の内容について
>どこを修正したら良いか分からなかったので、教えて頂ける
>と助かります。
>「台帳」シートに記載したVBAを下記します。
>CutCopyModeも記載していなかったのも、問題だったのでしょうか。
>
>Private Sub タグ作成_Click()
>Dim InPt As Long
>Dim c As Object
>Dim myKey As String
> Dim SaveName As String
> Dim wb As Workbook, wkbk As Workbook
> Set wb = ThisWorkbook
> InPt = Application.InputBox(prompt:="No.を入力して下さい。", Type:=1)
> If InPt = False Then Exit Sub
>Application.ScreenUpdating = False
>ActiveSheet.Unprotect
>myKey = InPt
>With ActiveSheet.Range("$c$5:$c$3000")
>Set c = .Find(What:=myKey, LookIn:=xlValues, lookat:=xlWhole, _
>SearchOrder:=xlByColumns, MatchByte:=False)
>If c Is Nothing Then
>MsgBox "No." & InPt & "は登録されていません。"
>Else
> ThisWorkbook.Sheets("タグ").Visible = True
> Sheets("タグ").Activate
> With wb.ActiveSheet
> .Range("c3").Value = InPt
> .Range("B2:C16").Copy
> End With
> Set wkbk = Workbooks.Add
> With wkbk.ActiveSheet
> .Range("B2").PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
> .Range("B2").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
> .Columns("A:A").ColumnWidth = 0.5
> .Columns("B:B").ColumnWidth = 10
> .Columns("C:C").ColumnWidth = 50
> .Columns("d:d").ColumnWidth = 0.5
> .Rows("1:1").RowHeight = 5
> .Rows("17:17").RowHeight = 5
> .Columns("E:IV").EntireColumn.Hidden = True
> .Rows("18:65536").EntireRow.Hidden = True
> End With
> With ActiveWindow
> .DisplayGridlines = False
> .DisplayHeadings = False
> .DisplayOutline = False
> .DisplayZeros = False
> .DisplayHorizontalScrollBar = False
> .DisplayVerticalScrollBar = False
> .DisplayWorkbookTabs = False
> End With
> SaveName = "C:\Documents and Settings\123\デスクトップ\" & InPt & "タグ.xls"
> Application.DisplayAlerts = False
> ActiveSheet.Range("c3").Locked = True
> ActiveSheet.Protect password:="1234"
> ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
> ActiveWorkbook.SaveAs Filename:=SaveName, FileFormat:=xlNormal, password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
> wkbk.Close False
> Sheets("タグ").Activate
> Selection.ClearContents
> ThisWorkbook.Sheets("タグ").Visible = xlSheetVeryHidden
> Sheets("台帳").Activate
> MsgBox "タグ作成しました。"
> Set wb = Nothing
> Set wkbk = Nothing
>End If
>End With
>ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
>End Sub
>▼n さん：
>>DisplayFormulaBarとDisplayStatusBarの設定時にCutCopyModeがFalseになるのが原因です。
>>
>>>表内のデータをコピーして、新規bookを開き、形式選択で書式と
>>>値を貼り付けた後、指定した名称で保存するというVBAを組んでいるのですが、
>>>そこでエラーが発生しました。
>>マクロで実行しているわけですから、その中でApplication.EnableEventsプロパティを制御して
>>Workbook_WindowDeactivateイベントが走らないようにすれば良いです。
>>
>>もしくは、
>>Sub test()
>> With Workbooks.Add(xlWBATWorksheet) 'ここでWindowDeactivateイベントが発生する
>> ThisWorkbook.Sheets("台帳").Range("A1").Copy
>> With .Sheets(1).Range("A1")
>> .PasteSpecial xlPasteValues
>> .PasteSpecial xlPasteFormats
>> End With
>> Application.CutCopyMode = False
>> .SaveAs "c:\temp\temp.xls"
>> .Close
>> End With
>>End Sub
>>このようにWindowDeactivateイベントの後でCopyメソッドを発行するような順番にすれば良いです。
>>基本的には、EnableEventsプロパティでの制御をおすすめします。
>>
>>#手作業でもコピー可能にしたい場合は、ひと工夫必要です。
|
|
らいち
- 10/1/11(月) 11:44 -
