Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

34768 / 76734

←次へ　｜　前へ→


	【47172】Re:セルと一緒に編集許可範囲もコピーしたい

りん

- 07/3/2(金) 21:09 -


	引用なし

	パスワード

ＧＨＱさん、こんばんわ。

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

正しいかどうかは不明ですがセットしてみました
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

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

7 hits

▼

【47113】セルと一緒に編集許可範囲もコピーしたい ＧＨＱ 07/3/1(木) 12:04