Excel VBA質問箱 IV

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

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


34772 / 76738 ←次へ | 前へ→

【47172】Re:セルと一緒に編集許可範囲もコピーしたい
回答  りん E-MAIL  - 07/3/2(金) 21:09 -

引用なし
パスワード
   GHQ さん、こんばんわ。

>お目当ての設定名称を見つけるまでループする場合、
>正しい書き方はどうすればよいでしょうか?

正しいかどうかは不明ですがセットしてみました
Sub Test()
  Dim II As Integer, addname As String, obj1 As Object
  Dim r1 As Range, r2 As Range, resp As Integer, aer As String
  '
  aer = "内工費明細" '下方向にコピーする設定名
  '
  With Application.ActiveSheet
   .Unprotect
   'あったらセット
   On Error Resume Next
   Set r2 = .Protection.AllowEditRanges.Item(aer).Range
   On Error GoTo 0
   '
   If r2 Is Nothing Then
     resp = MsgBox("それでもコピーしますか?", vbYesNo, aer & "がありません")
   Else
     resp = vbYes
   End If
   '
   If resp = vbYes Then
     MsgBox r2.Address
     For II = 1 To 100
      Set r1 = .Cells((II - 1) * 17 + 27, 2)
      '
      .Range("B10:F26").Copy Destination:=r1
      If Not r2 Is Nothing Then
        '編集許可をセルを追加
        '適当な名前
        addname = "Add_" & Format(II, "0000")
        '有無チェック(あればDel)
        On Error Resume Next
        Set obj1 = .Protection.AllowEditRanges.Item(addname)
        On Error GoTo 0
        If Not obj1 Is Nothing Then
         obj1.Delete
         Set obj1 = Nothing
        End If
        '再設定
        .Protection.AllowEditRanges.Add _
         Title:=addname, _
         Range:=r2.Offset(17 * II, 0)
      End If
     Next
     '範囲が拡張されるので戻す
     If Not r2 Is Nothing Then
      Set .Protection.AllowEditRanges.Item(aer).Range = r2
     End If
   End If
   '
   Set r1 = Nothing: Set r2 = Nothing
  End With
End Sub

複数ある場合はコピーで範囲が変わる可能性が高いので注意が必要かもしれません。

1 hits

【47113】セルと一緒に編集許可範囲もコピーしたい GHQ 07/3/1(木) 12:04 質問
【47116】Re:セルと一緒に編集許可範囲もコピーしたい りん 07/3/1(木) 14:30 発言
【47117】Re:セルと一緒に編集許可範囲もコピーしたい GHQ 07/3/1(木) 16:11 回答
【47130】Re:セルと一緒に編集許可範囲もコピーしたい りん 07/3/1(木) 19:35 回答
【47151】Re:セルと一緒に編集許可範囲もコピーしたい GHQ 07/3/2(金) 15:29 質問
【47172】Re:セルと一緒に編集許可範囲もコピーしたい りん 07/3/2(金) 21:09 回答
【47234】Re:セルと一緒に編集許可範囲もコピーしたい GHQ 07/3/5(月) 18:41 お礼

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