Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


18147 / 76738 ←次へ | 前へ→

【64034】Re:メニューバーの非表示について
お礼  らいち  - 10/1/11(月) 11:44 -

引用なし
パスワード
   とりあえず、下記の通りにコードを追加してみたら
うまくいきました!有難う御座いました。
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プロパティでの制御をおすすめします。
>>
>>#手作業でもコピー可能にしたい場合は、ひと工夫必要です。

0 hits

【63991】メニューバーの非表示について らいち 10/1/8(金) 18:13 質問
【63998】Re:メニューバーの非表示について n 10/1/9(土) 16:23 発言
【64032】Re:メニューバーの非表示について らいち 10/1/11(月) 9:25 質問
【64034】Re:メニューバーの非表示について らいち 10/1/11(月) 11:44 お礼
【64035】Re:メニューバーの非表示について n 10/1/11(月) 17:16 発言
【64040】Re:メニューバーの非表示について らいち 10/1/12(火) 10:28 質問
【64041】Re:メニューバーの非表示について n 10/1/12(火) 16:04 発言
【64042】Re:メニューバーの非表示について らいち 10/1/12(火) 18:06 お礼
【64119】Re:メニューバーの非表示について らいち 10/1/20(水) 17:02 質問
【64122】Re:メニューバーの非表示について n 10/1/20(水) 20:06 発言
【64129】Re:メニューバーの非表示について n 10/1/21(木) 1:31 発言
【64134】Re:メニューバーの非表示について らいち 10/1/21(木) 14:11 質問
【64137】Re:メニューバーの非表示について n 10/1/21(木) 19:33 発言
【64138】有難う御座いました。 らいち 10/1/21(木) 19:39 お礼

18147 / 76738 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free