Excel VBA質問箱 IV

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

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


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

209 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【78271】Re:飛び飛びのセルに一次元配列を配列で...

himuro - 16/6/15(水) 16:27 -


	引用なし

	パスワード

▼β さん：
>▼himuro さん：
>
>もう１つ申し上げておきます。
>転記元がどうなっているのかにもよりますが、効率アップは、転記時の話です。
>
>転記元セル領域 --> いったん配列に納めて --> 転記先セル領域に書き込み
>
>これでは、かえって（微々たるものですが）処理時間が増えます。
>こういう場合なら転記元セル領域から転記先セル領域に書きこむべきですよ。

なるほど、具体的にはこのような感じになります。

'wordは可変。１つだったり２０個だったりする。
dim word: word = "a, b, c, d, e, f, g, h, i, j, k, l, m, n, o"

dim arr1: arr1 = split(word, ",")

dim i, max: max = UBound(arr1)

dim a as range

'alphaはrange("A1:A10, C1:C10, E1:E10")の名前付きセル
for each a in alpha
a = arr1(i)
i = i + 1
if i > max then exit for
next a

このようなコードを、配列を使うことにより効率化できるでしょうか。

・ツリー全体表示


	【78270】Re:飛び飛びのセルに一次元配列を配列で...

β - 16/6/15(水) 16:05 -


	引用なし

	パスワード

▼himuro さん：

もう１つ申し上げておきます。
転記元がどうなっているのかにもよりますが、効率アップは、転記時の話です。

転記元セル領域 --> いったん配列に納めて --> 転記先セル領域に書き込み

これでは、かえって（微々たるものですが）処理時間が増えます。
こういう場合なら転記元セル領域から転記先セル領域に書きこむべきですよ。

・ツリー全体表示


	【78269】Re:飛び飛びのセルに一次元配列を配列で...

β - 16/6/15(水) 16:01 -


	引用なし

	パスワード

▼himuroさん

確かにセル範囲への値書き込みは　セル毎に行うより、まとめて、どさっと書きこんだほうが
圧倒的に効率はよくなります。
（例に挙げられたのは　サンプル　というか考え方でしょうけど、これぐらいのセル数なら
　ほとんど変わりはありませんが）

ただし、とびとびの複数セル領域への一括書きこみは不可能です。
あくまで、１領域ごとの書き込みになります。

次に、具体的には、どこの値をそれぞれのセル範囲に転記したいのでしょうか。
それを（１つの例としてでもいいので）提示願えませんか。
そのほうが、より具体的な回答につながると思いますので。

お先走って申し上げると、値を格納する配列は、今回の場合、全体としては１次元配列、
その中の要素が、各領域に書きこむべき２次元配列になると思います。

・ツリー全体表示


	【78268】Re:クリックしてセルの色を変える時

sea - 16/6/15(水) 15:33 -


	引用なし

	パスワード

▼独覚さん：
返信有り難うございます。

VBAの事は、全く理解しないまま試みていました。
一から勉強し直します。

ありがとうございました。

・ツリー全体表示


	【78267】飛び飛びのセルに一次元配列を配列で代入...

himuro - 16/6/15(水) 14:13 -


	引用なし

	パスワード

一次元配列の値を、飛び飛びのセル範囲に配列を使って代入する方法を教えて下さい。

飛び飛びのセル範囲は、alphaという名前付きセルで、A1:A5, C1:C5, E1:E5を参照している事にします。

一次元配列の値が"a, b, c, d, e, f, g..."だとすると、
A1からA5にはa~eが、C1~C5にはf~j, E1~E5にはk~oが入る感じです。

for eachで飛び飛びのセル範囲を一つずつ走査して代入する事はできましたが、やはり速度が気になるので配列を使って処理したいです。

２次元配列を作り、その配列に最初の一次元配列の値を格納して、
最後にalphaに代入する感じでしょうか。

しかし具体的なコードの書き方がいまいち分かりません。
よろしくお願いします。

・ツリー全体表示


	【78266】Re:クリックしてセルの色を変える時

独覚 - 16/6/15(水) 13:39 -


	引用なし

	パスワード

▼sea さん：
それは分かったうえで使っているのだと思っていました。

SelectionChangeは選択セルが変更された場合に実行されるイベントです。
なので現在選択しているセルをもう一度選択しても反応しません。

で、クリック時に発生するイベントはありません。
（なので上記のVBAも代わりにSelectionChangeを使っている）

代わりに使えるものは
ダブルクリック
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

右クリック
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

なお、ダブルクリック時はTargetは必ず一つのセルになるので現在のVBAで組まれている
複数セル対応は必要なくなります。
（あってもおかしくなることはありませんが）

あと、右クリックおよびダブルクリック時の通常の動作を抑制したい場合は
Cance = True
が必要になります。

・ツリー全体表示


	【78265】Re:クリックしてセルの色を変える時

sea - 16/6/15(水) 12:44 -


	引用なし

	パスワード

▼独覚さん：
ありがとうございます！
>>If (i > UBound(iAry)) Then i = 0
>を
>>If (i > UBound(iAry)) Then i = 1
>かな。

こちらで、思い通りの動作が出来ました。

更に一つ質問ですが、（灰色もしくは黄色に）一度色を変えた後に
直ぐに色を変えようとする場合、続けざまにクリックしても色は変わらず
一度別のセルをクリックしないと変えることが出来ません。
一つのセルで、クリックを続けざまに行い色を変える設定は可能でしょうか。

・ツリー全体表示


	【78264】Re:クリックしてセルの色を変える時

独覚 - 16/6/15(水) 10:30 -


	引用なし

	パスワード

▼sea さん：
セルの色は最初から黄色か灰色になっているのでしょうか？
もし背景色が何もない状態から始める場合、一回目のクリックでは何色にするのでしょうか？

もし、最初から黄色か灰色になっているのであれば

>iAry = Array(xlPatternNone, 56, 6)
を
>iAry = Array(56, 6)
でいいと思いますが。

もし、最初は背景色なしで有れば
>iAry = Array(xlPatternNone, 56, 6)
はそのままで
>If (i > UBound(iAry)) Then i = 0
を
>If (i > UBound(iAry)) Then i = 1
かな。

なおこの場合、一回目のクリックの色は
>iAry = Array(xlPatternNone, 56, 6)
の56と6の順番を変えることで変更できます。

また、あくまでもseaさんの書いたＶＢＡを生かす形での変更です。

・ツリー全体表示


	【78263】クリックしてセルの色を変える時

sea - 16/6/15(水) 9:42 -


	引用なし

	パスワード

一部のセルの色を、クリックすることで黄色⇔灰色に変えたく、ネットで見つけた
ものを使用してみたのですが、間に白が入ってしまいます。この白を省いて
クリック毎に黄色⇔灰色にするにはどうすればよいでしょうか。
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
　　Dim iAry As Variant
　　Dim r As Range
　　Dim i As Long

　　iAry = Array(xlPatternNone, 56, 6)

　　Set Target = Intersect(Target, Range("b:f"))
　　If (Target Is Nothing) Then Exit Sub

　　For Each r In Target
　　　　For i = 0 To UBound(iAry)
　　　　　　If (iAry(i) = r.Interior.ColorIndex) Then Exit For
　　　　Next
　　　　i = i + 1
　　　　If (i > UBound(iAry)) Then i = 0
　　　　r.Interior.ColorIndex = iAry(i)
　　Next
End Sub

・ツリー全体表示


	【78262】Re:貼り付け禁止のマクロ

sy - 16/6/12(日) 21:16 -


	引用なし

	パスワード

▼さささん：

初めのコードは切取に反応しませんでした。
条件分岐が複雑なので、修正を繰り返してたら、切取の確認を忘れてました。

修正コードを提示します。
一応コピペ、カット＆ペースト、値のみコピペの基本的な使い方では不具合は無いと思いますが(全部は検証しきれてないので絶対大丈夫とは言い切れないですが)、カットモードにして直接入力など、ユーザーはどんな使い方するか分からないので、意図しない動きをする可能性はあります。
もし不具合が起きたら、また質問して下さい。
(対処可能かどうかは保証できませんが)

後Undoした時は都度MsgBoxが出てくると思いますが、これはVBAでは対処不可能です。
多分全て「はい」で良いと思いますが、逆のパターンもありうるので、そこは使用者に慣れてもらうしかないです。

VBAではMsgBoxとの併用は限界があります。
APIでキーのクリックの常時監視などをすれば、大抵の事は対処できますが、Undoが効かなくなるのと、Undoをクリックした時の処置はAPIでも不可能と思います。

もう複雑すぎて説明は無理です。
ThisWorkbookモジュールに丸ごとコピペして下さい。

Private Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "User32" () As Long
Private Declare Function EmptyClipboard Lib "User32" () As Long

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
　　Dim Ans As Integer
　　Dim cb As Object, cbID As Integer, val
　　Dim val1, cnt As Long
　　Dim v, str1 As String
　　Dim flg As Boolean, mode1 As Variant

　　Application.EnableEvents = False
　　mode1 = modeID(0, Target)
　　If mode1(1) > 0 Then
　　　　cbID = Application.ClipboardFormats(1)
　　　　If cbID > -1 Or mode1(0) > 0 Then
　　　　　　If Application.CutCopyMode Then
　　　　　　　　flg = True
　　　　　　Else
　　　　　　　　val1 = Target.Value
　　　　　　　　cnt = Selection.Count
　　　　　　　　If cbID > -1 Then
　　　　　　　　　　Set cb = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
　　　　　　　　　　cb.GetFromClipboard
　　　　　　　　　　val = cb.GetText
　　　　　　　　　　If cnt = 1 Then
　　　　　　　　　　　　If InStr(val1, val) > 0 Then flg = True
　　　　　　　　　　Else
　　　　　　　　　　　　flg = True
　　　　　　　　　　　　For Each v In val1
　　　　　　　　　　　　　　If v <> "" Then
　　　　　　　　　　　　　　　　If InStr(val, v) = 0 Then
　　　　　　　　　　　　　　　　　　flg = False
　　　　　　　　　　　　　　　　　　Exit For
　　　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　　End If
　　　　　　　　　　　　Next v
　　　　　　　　　　End If
　　　　　　　　Else
　　　　　　　　　　If mode1(0) = 2 Then flg = True
　　　　　　　　End If
　　　　　　End If

　　　　　　If Selection.Address <> mode1(2) And mode1(0) <> 2 Then flg = False

　　　　　　If flg Then
　　　　　　　　Ans = MsgBox("本当に貼り付けますか？", vbYesNo, "確認")
　　　　　　　　If Ans = vbNo Then
　　　　　　　　　　MsgBox "正しいデータを貼り付けてください"
　　　　　　　　　　Application.Undo
　　　　　　　　　　OpenClipboard (0&)
　　　　　　　　　　EmptyClipboard
　　　　　　　　　　CloseClipboard
　　　　　　　　End If
　　　　　　End If
　　　　End If
　　End If
　　If mode1(0) < 2 Then Call modeID(2, Target)
　　Application.EnableEvents = True

End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

　　Call modeID(1, Target)

End Sub

Function modeID(ID As Integer, rng As Range) As Variant
　　Static CopyMode As Integer, i As Integer, tgt As String

　　tgt = ""
　　Select Case ID
　　　　Case 0
　　　　　　If i = 0 Then
　　　　　　　　i = 1
　　　　　　Else
　　　　　　　　i = 0
　　　　　　　　CopyMode = 0
　　　　　　End If
　　　　Case 1
　　　　　　CopyMode = Application.CutCopyMode
　　　　　　tgt = rng.Address
　　　　　　i = 0
　　　　Case 2
　　　　　　i = 0
　　　　　　CopyMode = 0
　　End Select
　　If tgt = "" Then tgt = rng.Address
　　modeID = Array(CopyMode, i, tgt)

End Function

▼マナさん：

>途中で考えるのが、いやになっちゃいます。

同感です。
途中で訳わからなくなってきました。

>選択制にしたい場合は、変数を用意して、必要に応じて、
>コピペ禁止モードを解除する運用でもよいかもしれません。
>If IsCopyOK then exit sub
>みたいな感じにすれば、学校のコードが使えるかなと思います。

完全禁止なら対処も簡単ですね。
不具合も出ないでしょうし、私も選択制をお勧めします。

・ツリー全体表示


	【78261】Re:貼り付け禁止のマクロ

マナ - 16/6/12(日) 18:23 -


	引用なし

	パスワード

▼sy さん：
>
>ただこちらの案件ではMsgBoxで貼付を選択するようになっているので、消去した時との区別が出来ないので、かなり難しいですね。
>多少妥協してもらう部分はありますがIF分岐で考えてみました。
>
syさん、コメントありがとうございます。
すごいですね。わたしには、とうてい考えられません。
途中で考えるのが、いやになっちゃいます。

質問者さんに確認しないとわかりませんが
おそらく、MsgBoxによる選択は不要かもしれません。
たまたま、ネットで見つけたサンプルがそうなっていただけで。

選択制にしたい場合は、変数を用意して、必要に応じて、
コピペ禁止モードを解除する運用でもよいかもしれません。

If IsCopyOK then exit sub

みたいな感じにすれば、学校のコードが使えるかなと思います。

・ツリー全体表示


	【78260】Re:貼り付け禁止のマクロ

sy - 16/6/12(日) 3:05 -


	引用なし

	パスワード

こんばんわ。

マナさんが言ってた案件はこちらですね。

>　If Target.Count = 1 Then
に関してはマナさんのアドバイス通りと思います。

>　　　If Application.CutCopyMode Then
こちらの判定部分ですが、セルに貼り付けれるデータでCutCopyMode が有効になるのは、セルを選択した時だけです。
文字を直接選択してコピーした時や、他のアプリからのデータコピーには対応できません。
そう言うデータも禁止にするなら、以下のようにクリップボードの中にデータがあるかを判定した方が良いです。
　　　　If Application.ClipboardFormats(1) > -1 Then

ただこちらの案件ではMsgBoxで貼付を選択するようになっているので、消去した時との区別が出来ないので、かなり難しいですね。
多少妥協してもらう部分はありますがIF分岐で考えてみました。

ThisWorkbookモジュールに以下を記述して下さい。

Private Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "User32" () As Long
Private Declare Function EmptyClipboard Lib "User32" () As Long

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
　　Dim Ans As Integer, cb As Object, val As String

　　Application.EnableEvents = False
　　If Target.Address = Selection.Address Then
　　　　If Application.ClipboardFormats(1) > -1 Then
　　　　　　Set cb = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
　　　　　　cb.GetFromClipboard
　　　　　　val = cb.GetText
　　　　　　If (Len(val) = 0 And Application.CutCopyMode = 0) Or _
　　　　　　　　　　(Len(val) = 2 And Application.CutCopyMode > 0) Then
　　　　　　　　Application.Undo
　　　　　　　　OpenClipboard (0&)
　　　　　　　　EmptyClipboard
　　　　　　　　CloseClipboard
　　　　　　Else
　　　　　　　　If Not IsEmpty(Target.Value) Then
　　　　　　　　　　Ans = MsgBox("本当に貼り付けますか？", vbYesNo, "確認")
　　　　　　　　　　If Ans = vbNo Then
　　　　　　　　　　　　MsgBox "正しいデータを貼り付けてください"
　　　　　　　　　　　　Application.Undo
　　　　　　　　　　　　OpenClipboard (0&)
　　　　　　　　　　　　EmptyClipboard
　　　　　　　　　　　　CloseClipboard
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　End If
　　　　End If
　　End If
　　Application.EnableEvents = True

End Sub

上記コードは値の消去やDelete・BackSpaceなどでは反応しません。
代わりに空白セルや長さ0の文字列をコピーした場合にUndoが働き貼付出来ません。
それと文字選択状態(f2を押した時)での貼付はメッセージも出ず貼付出来てしまいます。
上の2つは消去との区別が出来ませんでした。

・ツリー全体表示


	【78259】Re:貼り付け禁止のマクロ

マナ - 16/6/11(土) 22:59 -


	引用なし

	パスワード

▼さささん：

>　If Target.Count = 1 Then

を見なおせば、

>結合したセルや複数のセルを選択した場合には
>適応出来ていません。

これは解決できるのですが
実際は、単セルの場合でも、気がついていないだけで、
貼り付けできちゃう可能性があります。

他板ですが、類似の質問がありましたので紹介します。
タイトルからは、全然関係なさそうに見えますが、そんなことありません。
わたしのおすすめは、syさんの回答です。
よろしければ試してみてください。

ht　tp://www.excel.studio-kazu.jp/kw/20160611090857.html

・ツリー全体表示


	【78258】Re:BeforeDoubleClick　のタブレットPCで...

γ - 16/6/11(土) 6:51 -


	引用なし

	パスワード

▼hapisan さん：
>そのまま貼り付けてみて確認してみましたが、
>PC上ではメッセージBOXの起動が確認できましたが、タブレット上では確認できませんでした。

ということは、ご質問にあったコードの問題ではなく、
タブレット上で、ダブルクリックに相当する操作をするためには、
どうすべきか、という問題だということですね。

問題の切り分けができたところで、私は失礼します。
タブレットPCを持ち合わせていないので、まったく分かりません。

・ツリー全体表示


	【78257】Re:貼り付け禁止のマクロ

マナ - 16/6/10(金) 21:02 -


	引用なし

	パスワード

▼さささん：

>　If Target.Count = 1 Then

この行の意味を教えて下さい

・ツリー全体表示


	【78256】Re:BeforeDoubleClick　のタブレットPCで...

hapisan - 16/6/10(金) 17:00 -


	引用なし

	パスワード

▼β さん：

ご回答ありがとうございます。

提案いただいた、タップ後に再度ダブルタップを試してみましたが、
やはり起動しませんでした。

先に回答いただいたγさんのコードでも同様に試しましたが、
こちらもダメでした。

>こちら、モバイル音痴で、タブレットは、もっぱらメールとヤフー検索ぐらいで
>アプリケーションを動かすことは、めったにないので、すべっている公算大ですが。
>
>そのセルを、一度タップして選択してから、あらためて　パンパン　とやるとどうなるでしょうか。

・ツリー全体表示


	【78255】Re:BeforeDoubleClick　のタブレットPCで...

hapisan - 16/6/10(金) 16:58 -


	引用なし

	パスワード

▼γ さん：

ご回答ありがとうございます。

そのまま貼り付けてみて確認してみましたが、
PC上ではメッセージBOXの起動が確認できましたが、タブレット上では確認できませんでした。

>私の手元に環境が無いので、ろくな回答はできませんが、
>とりあえず、
>Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
>　　Msgbox "Double Clicked"　　
>End Sub
>といった簡単なものの振る舞いを確認してみたらどうですか？

・ツリー全体表示


	【78254】貼り付け禁止のマクロ

ささ - 16/6/10(金) 16:34 -


	引用なし

	パスワード

いつもありがとうございます。

早速ですが、表題の通りのマクロを組みたいと考えています。
ネットで色々調べましたが意図する着地点へと到達できません。

現在は、単セルの貼り付け禁止まではできていますが、
結合したセルや複数のセルを選択した場合には
適応出来ていません。

どちらかというと、複数セルを選択した場合の貼付けを禁止としたいです。

現状は以下のとおりです。

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

　Dim Ans As Integer

　If Target.Count = 1 Then
　　　If Application.CutCopyMode Then
　　　　　Ans = MsgBox("本当に貼り付けますか？", vbYesNo, "確認")
　　　　　If Ans = vbNo Then
　　　　　　　MsgBox "正しいデータを貼り付けてください"
　　　　　　　With Application
　　　　　　　　.EnableEvents = False
　　　　　　　　.Undo
　　　　　　　　.EnableEvents = True
　　　　　　　End With
　　　　　End If
　　　　　Application.CutCopyMode = False
　　　End If
　End If
End Sub

よろしくお願いいたします。

・ツリー全体表示


	【78253】Re:BeforeDoubleClick　のタブレットPCで...

β - 16/6/10(金) 7:41 -


	引用なし

	パスワード

▼hapisan さん：

こちら、モバイル音痴で、タブレットは、もっぱらメールとヤフー検索ぐらいで
アプリケーションを動かすことは、めったにないので、すべっている公算大ですが。

そのセルを、一度タップして選択してから、あらためて　パンパン　とやるとどうなるでしょうか。

・ツリー全体表示


	【78252】Re:BeforeDoubleClick　のタブレットPCで...

γ - 16/6/9(木) 20:35 -


	引用なし

	パスワード

私の手元に環境が無いので、ろくな回答はできませんが、
とりあえず、
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
　　Msgbox "Double Clicked"　　
End Sub
といった簡単なものの振る舞いを確認してみたらどうですか？

・ツリー全体表示


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

209 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free