[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『EXCEL VBA 行追加 禁止マクロ 』(あやころ)
EXCEL VBA 行追加 禁止マクロ
VBA初心者です。
EXCEL VBAを利用して、
名前の定義された範囲への行の追加禁止のVBAを組みたいです。たとえばA1:G50の範囲に”売上”という名前を定義しているとすると、
その”売上”のセル範囲への行追加を禁止したいです。
ネットにて、先頭行追加禁止の構文は見つけたのですが、
これら構文を、どのように変更すべきかお教え頂けないでしょうか?
よろしくお願いいたします。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim m_Address As String, m_BeforeRange As Range
If Target.Item(1).Row = 1 Then
m_Address = Target.Address
With Application
.EnableEvents = False
.Undo
Set m_BeforeRange = Me.Range(m_Address).Item(1)
.Repeat
If m_BeforeRange.Row <> Me.Range(m_Address).Item(1).Row Then
Me.Range(m_Address).Delete
MsgBox "1行目への挿入は禁止されています。", vbExclamation
End If
.EnableEvents = True
End With
End If
End Sub
< 使用 Excel:Excel2007、使用 OS:Windows7 >
何故に特定の範囲だけ禁止したいのですか? マクロということは、無効で開かれたときは禁止できないわけですよね?
考え方としてはシートを保護して、必要な範囲をVBAで行追加させるというのが プログラムとして自然な流れだと思います。
最初の質問に戻りますが、何故禁止したいのかを説明いただければ、他の解答も できるのではないかと思います。
(稲葉) 2015/08/27(木) 08:38
ID非公開さん、こんにちは。
回答者への参考です。
http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q14149248104?__ysp=RXhjZWwgVkJB6LOq5ZWP566xIElWIOmWsuimpyDkuI3lj68%3D
(マルチネス) 2015/08/27(木) 08:55
素朴な疑問なんですが、A1:G50 の領域内のいくつかのセルを選択して、セル挿入操作を行うのはOKなんですか?
(β) 2015/08/27(木) 09:02
追加です。
"売上"という領域の行を増やしたくない(減らすのはいい?)ということならわかるのですが 1行目に挿入するということは、売上という領域は1行、下に移動しますが、領域内の構成は変更ないわけですよね。 それを禁止するという目的がちょっとわからないです。
こちらがわからないだけで、ちゃんとした目的があるとすれば、変更前の状態の"売上"領域の先頭行が 変更後の先頭行と同じであり、変更前の行数と変更後の行数も同じというチェックをかければいいとは思いますが。
ところで、列は挿入しても削除してもいいのですか?
(β) 2015/08/27(木) 09:58
A1:G50のセル範囲を「売上」という名前で定義と聞くと 区分 コード 品名 数量 単位 単価 金額
又は、
コード 品名 数量 単位 単価 金額 備考
なんて列を想像をしてしまいますが・・・。
いずれにせよ Excelは色んな事が出来るので逆に制限したい場合は気を使いますよね!!
売上 という名前の定義をされているセル囲は、行挿入や削除 列挿入や削除によって、
定義セル範囲が変わります。この性質を利用することを検討してみてください。
(ichinose) 2015/08/29(土) 20:56
売上 という領域がどういうものなのか、その領域に対して、どのような変更を禁止したいのかが不明ですが (β) 2015/08/27(木) 09:02 で、つぶやいたことが気になります。
新規ブックに以下を貼り付けて、実行してみて下さい。こういう変更はOKなんでしょうかね?
Sub これはいいのですか() Dim oldAddr As String
Cells.Clear Cells.Interior.ColorIndex = xlNone
With Range("B4:D9") .Value = "売上" .Interior.Color = vbYellow ThisWorkbook.Names.Add Name:="売上", RefersTo:="=" & .Address oldAddr = Range("売上").Address
MsgBox "領域を確認してください" & vbLf & "今から領域内のセルを基準に挿入します" Range("C5").Insert Shift:=xlDown
End With
MsgBox "領域 売上のアドレス" & vbLf & "挿入前:" & oldAddr & vbLf & "挿入後:" & Range("売上").Address & vbLf & "同じなんですが、いいのでしょうか?"
End Sub
(β) 2015/08/29(土) 22:37
個別のセルの挿入操作もあるなら、名前の定義を以下のようにするお方法でも 行けると思います
Sub mk_name() Dim rng As Range Dim g0 As Long Set rng = Range("a1:g50") For g0 = 1 To rng.Rows.Count With rng.Rows(g0) .Name = "uri_" & Split(.EntireRow.Address(False, False), ":")(0) End With Next For g0 = 1 To rng.Columns.Count With rng.Columns(g0) .Name = "uri_" & Split(.EntireColumn.Address(False, False), ":")(0) End With Next End Sub
(ichinose) 2015/08/30(日) 19:58
売上 という領域の場所は移動してもいいけど、その大きさ、その構成セル群は変更禁止ということなら 少し長くなりますが。コードを整理すれば、もう少し、スッキリできるかもしれません。
Private Sub Worksheet_Change(ByVal Target As Range) Dim w As Variant Dim er As Boolean Dim x As Long Dim y As Long Dim z As Long Dim c As Range Dim r As Range Dim sv As String Dim tAddr As String sv = ActiveCell.Address tAddr = Target.Address
On Error Resume Next Set r = Range("売上") On Error GoTo 0
If r Is Nothing Then MsgBox "この変更操作はできません" Application.EnableEvents = False Application.Undo Application.EnableEvents = True Exit Sub End If
Application.EnableEvents = False Application.ScreenUpdating = False Application.Undo
If Intersect(Range(tAddr), Range("売上")) Is Nothing Then Application.Undo Application.EnableEvents = True Exit Sub End If
With Range("売上") x = .Columns.Count y = .Rows.Count ReDim w(1 To x * y) For Each c In .Cells z = z + 1 Set w(z) = c Next End With
Application.Undo
With Range("売上") If x <> .Columns.Count Or y <> .Rows.Count Then er = True Else For z = 1 To .Cells.Count Set c = Nothing On Error Resume Next Set c = Intersect(Range("売上"), w(z)) On Error GoTo 0 If c Is Nothing Then er = True End If
If er Then Exit For
Next End If
If er Then MsgBox "この変更操作はできません" Application.Undo Else Range(sv).Select End If End With
Application.EnableEvents = True
End Sub
(β) 2015/08/30(日) 21:43
↑ アップしたとたんに欠陥発見。
領域の左側、あるいは上方のセルを選択して挿入、削除を行うと、エラーにはひっかからず、領域のセル構成が 変更前とは異なるものになってしまいますね。
(つまり、変更前は領域に加わっていなかったセルが領域内に入る、あるいは変更後、領域内のセルが外に飛び出す)
ichinoseさんご提示のセル毎の名前にしておけば、各構成セルが変更後も領域内に残っているというチェックでいけそうですね。
(β) 2015/08/30(日) 21:48
領域外のセルを起点にして挿入を行ったときに、領域内のセルが、その領域を飛び出してしまうケースもチェック。 ただ、このシート上の、どの場所のどんな変更時もチェックが動いてしまうので(結果はからぶりですが)ちょっと、情けないですが。
以下の準備を実行してください(一回だけでOK) ichinoseさんが提示された領域内各セルに名前を付けます。("売上" という領域の各セルに 売上_1、売上_2、・・・)
Sub 準備() Dim nm As Name Dim x As Long Dim c As Range
For Each nm In ActiveWorkbook.Names If nm.Name Like "売上_*" Then nm.Delete Next
For Each c In Range("売上") x = x + 1 c.Name = "売上_" & x Next
End Sub
で、本番コード。シートモジュールに。
Private Sub Worksheet_Change(ByVal Target As Range) Dim er As Boolean Dim x As Long Dim y As Long Dim z As Long Dim r As Range Dim sv As String Dim tAddr As String Dim ck As Range
sv = ActiveCell.Address tAddr = Target.Address
On Error Resume Next Set r = Range("売上") On Error GoTo 0
If r Is Nothing Then MsgBox "この変更操作はできません" Application.EnableEvents = False Application.Undo Application.EnableEvents = True Exit Sub End If
Application.EnableEvents = False Application.ScreenUpdating = False Application.Undo
With Range("売上") x = .Columns.Count y = .Rows.Count End With
Application.Undo
With Range("売上") If x <> .Columns.Count Or y <> .Rows.Count Then er = True Else For z = 1 To x * y Set ck = Nothing On Error Resume Next Set ck = Intersect(.Cells, Range("売上_" & z)) On Error GoTo 0 If ck Is Nothing Then er = True Exit For End If Next End If
If er Then MsgBox "この変更操作はできません" Application.Undo Else Range(sv).Select End If End With
Application.EnableEvents = True
End Sub
(β) 2015/08/31(月) 17:29
(β) 2015/08/31(月) 17:29で書かれているコードがまさに私のやりたい事でした。
このコードをこのままコピーして使用したところ、"この変更操作はできません"の
メッセージボックスをOKをクリックして消した後、エクセル自体がフリーズしてし
まって、しばらく動かなくなります。
どうしたら動く様になるでしょうか?
PCのスペックの問題でしょうか?
教えてください。
(あやころ) 2015/09/04(金) 14:15
>>(β) 2015/08/31(月) 17:29で書かれているコードがまさに私のやりたい事でした。
ん? フリーズして動かないのに、確認できたのですか? それともテストブックでは動いたけど、本番ブックではフリーズ?
実際の "売上" という名前が付けられている領域(セルアドレス)を教えてください。
(β) 2015/09/04(金) 14:27
実際の”売上”の領域はA31:AI58です。
範囲が広すぎるせいでしょうか?
(あやころ) 2015/09/05(土) 08:02
同じ環境をつくって、何パターンかやってみましたが、こちらではフリーズしません。 (win7+xl2010、win8.1+xl2013) win7+xl2007 は環境がないので確認できませんが。
ただ、この2つの環境ともに不思議な現象が。
小さな領域(縦4行、横3列程度)の場合、範囲外の上のほうの行を選択して行挿入。 これは領域いの構成が変わることはなく移動するだけなので許しているんですが、 これをA31:AI58の大きな領域で行うと、その操作はできません となってしまいます。
フリーズはしませんが、領域の大きさにより、何かが違うんでしょうね。
しかし、いずれにしても、そちらの環境で、フリーズするなら、このアイデアは使えませんねぇ。
(β) 2015/09/05(土) 09:14
(β) 2015/08/31(月) 17:29に書かれているコードの途中で
Application.ScreenUpdating = True
を下記のようにいれることで、動くようになりました。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim er As Boolean
Dim x As Long
Dim y As Long
Dim z As Long
Dim r As Range
Dim sv As String
Dim tAddr As String
Dim ck As Range
sv = ActiveCell.Address
tAddr = Target.Address
On Error Resume Next
Set r = Range("売上")
On Error GoTo 0
If r Is Nothing Then
MsgBox "この変更操作はできません"
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
Exit Sub
End If
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.Undo
With Range("売上")
x = .Columns.Count
y = .Rows.Count
End With
Application.Undo
Application.ScreenUpdating = True
With Range("売上")
If x <> .Columns.Count Or y <> .Rows.Count Then
er = True
Else
For z = 1 To x * y
Set ck = Nothing
On Error Resume Next
Set ck = Intersect(.Cells, Range("売上_" & z))
On Error GoTo 0
If ck Is Nothing Then
er = True
Exit For
End If
DoEvents
Next
End If
Application.ScreenUpdating = True
If er Then
MsgBox "この変更操作はできません"
Application.Undo
Else
Range(sv).Select
End If
End With
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
(β)さん、本当にありがとうございました。
ちなみにこちらのPCでは(β) 2015/09/05(土) 09:14に書かれてる現象は起こりませんでした。
エクセルのバージョンでなにかが違うのでしょうね・・・
(あやころ) 2015/09/10(木) 18:17
>>Application.ScreenUpdating = True
あぁ、そういうことだったのかもしれませんね。 もし、そうであれば、ここは DoEvents でもいいかも。
かつ(おそらく)必要な場所は、最初のApplication.ScreenUpdating = True だけかもしれません。
Application.Undo が指示されて、でも、(メモリーの状態によっては)それが完全に機能して、元に戻る前に Range("売上") が参照される。 ここで、メモリーが固まってしまう。そんなことなのかもしれませんね。
勉強になりました。
(β) 2015/09/11(金) 00:08
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.