Excel VBA質問箱 IV

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

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


34809 / 76734 ←次へ | 前へ→

【47130】Re:セルと一緒に編集許可範囲もコピーしたい
回答  りん E-MAIL  - 07/3/1(木) 19:35 -

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

>手作業の場合、メニューのツール→保護→範囲の編集を許可を開き、
>=$BG$22,$BF$24:$BI$26,$BK$24:$BM$26,・・・・・
>てな具合に、複数の範囲をコンマで区切って記述しますが、
>編集許可範囲の一タイトルあたり、22組が限度のようです。
22組というより、グラフ等と同じく文字数の制限な気もします。
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, "許可設定が0または複数でした")
   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
     '1つめは範囲が拡張されるので戻す
     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
7 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 お礼

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