Excel VBA質問箱 IV

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

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


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

34813 / 76738

←次へ　｜　前へ→


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

りん

- 07/3/1(木) 19:35 -


	引用なし

	パスワード

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

>手作業の場合、メニューのツール→保護→範囲の編集を許可を開き、
>=$BG$22,$BF$24:$BI$26,$BK$24:$BM$26,･････
>てな具合に、複数の範囲をコンマで区切って記述しますが、
>編集許可範囲の一タイトルあたり、２２組が限度のようです。
２２組というより、グラフ等と同じく文字数の制限な気もします。
Sub Test()
　 Dim II As Integer
　 Dim r1 As Range, r2 As Range, resp As Integer
　 '
　 With Application.ActiveSheet
　　　.Unprotect
　　　If .Protection.AllowEditRanges.Count = 1 Then
　　　　 '設定が一つだけあったらセット（ほかは無視）
　　　　 Set r2 = .Protection.AllowEditRanges.Item(1).Range
　　　　 resp = vbYes
　　　Else
　　　　 MsgBox .Protection.AllowEditRanges.Count
　　　　 resp = MsgBox("コピーしますか？", vbYesNo, "許可設定が０または複数でした")
　　　End If
　　　'
　　　If resp = vbYes Then
　　　　 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
　　　　　　　 '編集許可をセルを追加
　　　　　　　 .Protection.AllowEditRanges.Add _
　　　　　　　　　Title:="Add_" & Format(II, "0000"), _
　　　　　　　　　Range:=r2.Offset(17 * II, 0)
　　　　　　End If
　　　　 Next
　　　　 '１つめは範囲が拡張されるので戻す
　　　　 If Not r2 Is Nothing Then
　　　　　　Set .Protection.AllowEditRanges.Item(1).Range = r2
　　　　 End If
　　　End If
　 End With
End Sub
こんな感じです。
コピーした後で、参照位置をOFFSETでずらして設定していきます。
'
パスワードを設定しないなら、書式で保護をしないほうが簡単ですね。

おまけ
Sub test2()
　 '一つ目の条件以外を削除
　 Dim II As Integer, IMax As Integer
　 With Application.ActiveSheet
　　　.Unprotect
　　　IMax = .Protection.AllowEditRanges.Count
　　　For II = IMax To 2 Step -1
　　　　 .Protection.AllowEditRanges.Item(II).Delete
　　　Next
　 End With
End Sub

1 hits

▼

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