Excel VBA質問箱 IV

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

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


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

122 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【80027】Re:オプションボタンのコードの簡略化を...

703 - 18/7/1(日) 11:25 -


	引用なし

	パスワード

ご回答ありがとうございました。
シートの方に書くことは初めてだったため、大変勉強になりました。
頂いたコードを元に改めて考えて、エラーなく動かすことができました。
大変ありがとうございました。

・ツリー全体表示


	【80026】Re:オプションボタンのコードの簡略化を...

703 - 18/7/1(日) 11:23 -


	引用なし

	パスワード

ご回答ありがとうございます。
仰る通り3の場合です。分かりづらい質問ですいませんでした。
頂いたコードを元に再度見直してみたところ
無事エラーなく動きました。
大変ありがとうございました。

・ツリー全体表示


	【80025】Re:オプションボタンのコードの簡略化を...

hatena - 18/6/30(土) 2:53 -


	引用なし

	パスワード

３．の場合だとすると、下記のコードでどうしょう。 Private Sub CommandButton1_Click() 　　Dim i As Long, j As Long 　　Dim rngOutput As Range, wsInput As Worksheet 　　Dim a As Long 　　Set wsInput = Worksheets("アンケート項目") 　　Set rngOutput = Worksheets("シートA").Range("投入範囲") 　　a = rngOutput.Rows.Count 　　rngOutput.Rows(a).Insert Shift:=xlDown 　　rngOutput.Cells(a, 1).Value = Me.TextBox1 　　　　For i = 1 To 17 　　　　With Me.Controls("Frame" & i) 　　　　For j = 0 To .Controls.Count - 1 　　　　　　If .Controls(j).Value Then 　　　　　　　　rngOutput.Cells(a, i + 1).Value = wsInout.Cells(j + 3, i + 2) 　　　　　　End If 　　　　Next 　　　　End With 　　Next End Sub

・ツリー全体表示


	【80024】Re:オプションボタンのコードの簡略化を...

hatena - 18/6/30(土) 1:45 -


	引用なし

	パスワード

▼703 さん：
>アンケートの集計フォームをつくっています。
>アンケートの設問がQ1~Q17まであり、各設問に答えがA1~A10またはA1~A20ほどあります。

>240個のオプションボタンがあり、チェックがついたら、そのオプションボタンに対応したセルの値を、別のシートのセルに投入していく(積上げていく)作業を繰り返し行いたいです。

オプションボタンといってもいろいろあります。
下記のどれでしょうか。

１．ワークシート上に、フォームコントロールのグループボックスとオプションボタンを配置した。

２．ワークシート上に Active X のオプションボタンを配置した。

３．ユーザーフォーム上に、フレームを配置して、その上にオプションボタンを配置した。

提示のコードから推測すると３．だと思いますが、どうですか。

・ツリー全体表示


	【80023】Re:オプションボタンのコードの簡略化を...

γ - 18/6/29(金) 18:45 -


	引用なし

	パスワード

いいんじゃないですか？
動きませんか？

・ツリー全体表示


	【80022】Re:オプションボタンのコードの簡略化を...

703 - 18/6/29(金) 9:07 -


	引用なし

	パスワード

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

今までシートモジュールに書いたことがなく
重ねての質問になってしまい申し訳ないのですが、

vbaの画面で投入シートを右クリックし、コードの表示を押し

そこに
Private Sub CommandButton2_Click()

Dim a As Integer
a = Worksheets("シートA").Range("投入範囲").Rows.Count
Worksheets("シートA").Range("投入範囲").Rows(a).Insert Shift:=xlDown
Worksheets("シートA").Range("投入範囲").Cells(a, 1).Value = TextBox1

Sub test()
　　Dim ws　As Worksheet
　　Dim rng As Range
　　Dim j　 As Long
　　Dim jj　As Long
　　Dim k　 As Long
　　Dim ruiseki As Long
　　Dim p　 As Long
　　Dim ary As Variant
　　
　　Set rng = Worksheets("シートA").Range("投入範囲")
　　Set ws = Worksheets("アンケート項目")
　　
　　'オプションの数
　　ary = Array(10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 20, 20, 20, 20, 20, 20, 20)
　　
　　For k = 1 To 17
　　　　For j = 1 To ary(k - 1)
　　　　　　jj = ruiseki + j
　　　　　　If Me.OLEObjects("OptionButton" & jj).Object.Value = True Then
　　　　　　　　rng.Cells(a, k + 1).Value = ws.Cells(j + 2, k + 1)
　　　　　　　　' Exit For
　　　　　　End If
　　　　Next
　　　　ruiseki = ruiseki + ary(k - 1)
　　Next
End Sub

を入力する形でよいのでしょうか。

・ツリー全体表示


	【80021】Re:オプションボタンのコードの簡略化を...

703 - 18/6/29(金) 9:01 -


	引用なし

	パスワード

よろずやさん
ご回答ありがとうございます。

提案頂いた通りに分割してみたところ、実行はできるのですが
ボタンクリック時に、毎回1番上の行のセルに入力されてしまいます。
投入範囲はボタンクリック毎に1つ下の行にずれているのですが、
どうすればよいでしょうか…

>240個のオプションボタンの規則性が判らないので、とりあえずプロシージャの分割のみの提案です。

質問が分かりづらくてすいません。
Q1-Q10は　A1-A10まで、
Q11-Q17は　A1-A20まで回答項目があります。

Q1だと　フレーム1つの中にオプションボタンを10個配置しているイメージです。

・ツリー全体表示


	【80020】Re:オプションボタンのコードの簡略化を...

γ - 18/6/29(金) 7:17 -


	引用なし

	パスワード

シートモジュールに書いてください。
テストを十分していないので、そちらで検証してください。

Sub test()
　　Dim ws　As Worksheet
　　Dim rng As Range
　　Dim j　 As Long
　　Dim jj　As Long
　　Dim k　 As Long
　　Dim ruiseki As Long
　　Dim p　 As Long
　　Dim ary As Variant
　　
　　Set rng = Worksheets("シートA").Range("投入範囲")
　　Set ws = Worksheets("アンケート項目")
　　
　　'オプションの数
　　ary = Array(10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 20, 20, 20, 20, 20, 20, 20)
　　
　　For k = 1 To 17
　　　　For j = 1 To ary(k - 1)
　　　　　　jj = ruiseki + j
　　　　　　If Me.OLEObjects("OptionButton" & jj).Object.Value = True Then
　　　　　　　　rng.Cells(a, k + 1).Value = ws.Cells(j + 2, k + 1)
　　　　　　　　' Exit For
　　　　　　End If
　　　　Next
　　　　ruiseki = ruiseki + ary(k - 1)
　　Next
End Sub

・ツリー全体表示


	【80019】Re:オプションボタンのコードの簡略化を...

よろずや - 18/6/29(金) 6:39 -


	引用なし

	パスワード

▼703 さん：
>色々なサイトを参考にし以下のようにコードを書いてみたのですが、
>プロシージャが大きすぎるエラーがでます。

240個のオプションボタンの規則性が判らないので、とりあえずプロシージャの分割のみの提案です。

>Private Sub CommandButton1_Click()
>
>Dim a As Integer
>a = Worksheets("シートA").Range("投入範囲").Rows.Count
>Worksheets("シートA").Range("投入範囲").Rows(a).Insert Shift:=xlDown
>Worksheets("シートA").Range("投入範囲").Cells(a, 1).Value = TextBox1
Call Q1_Proc
Call Q2_Proc
:
Call Q17_Proc
End Sub

Private Sub Q1_Proc()
>If Frame1.OptionButton1.Value = True Then
>Worksheets("シートA").Range("投入範囲").Cells(a, 2).Value = Worksheets("アンケート項目").Cells(3, 2)
>ElseIf Frame1.OptionButton2.Value = True Then
>Worksheets("シートA").Range("投入範囲").Cells(a, 2).Value = Worksheets("アンケート項目").Cells(4, 2)
>
>…これが続いて
>
>ElseIf Frame1.OptionButton10.Value = True Then
>Worksheets("シートA").Range("投入範囲").Cells(a, 2).Value = Worksheets("アンケート項目").Cells(12, 2)
>
>Else
>End If
End Sub

Private Sub Q2_Proc()
>If Frame2.OptionButton11.Value = True Then
>Worksheets("シートA").Range("投入範囲").Cells(a, 3).Value = Worksheets("アンケート項目").Cells(3, 3)
>ElseIf Frame2.OptionButton12.Value = True Then
>Worksheets("シートA").Range("投入範囲").Cells(a, 3).Value = Worksheets("アンケート項目").Cells(4, 3)
>
>…と続き
>
>ElseIf Frame17.OptionButton240.Value = True Then
>Worksheets("シートA").Range("投入範囲").Cells(a, 18).Value = Worksheets("アンケート項目").Cells(22, 18)
>
>End Sub

・ツリー全体表示


	【80018】オプションボタンのコードの簡略化をした...

703 - 18/6/29(金) 0:43 -


	引用なし

	パスワード

お世話になります。
マクロを勉強中の初心者です。
アンケートの集計フォームをつくっています。
アンケートの設問がQ1~Q17まであり、各設問に答えがA1~A10またはA1~A20ほどあります。

240個のオプションボタンがあり、チェックがついたら、そのオプションボタンに対応したセルの値を、別のシートのセルに投入していく(積上げていく)作業を繰り返し行いたいです。

色々なサイトを参考にし以下のようにコードを書いてみたのですが、プロシージャが大きすぎるエラーがでます。
どうすればシンプルなコードになるでしょうか。for next構文など、調べているのですが、なかなかうまくいかず、シンプルにしたコードを教えて頂きたいです。

以下コードです。
Private Sub CommandButton1_Click()

Dim a As Integer
a = Worksheets("シートA").Range("投入範囲").Rows.Count
Worksheets("シートA").Range("投入範囲").Rows(a).Insert Shift:=xlDown
Worksheets("シートA").Range("投入範囲").Cells(a, 1).Value = TextBox1

If Frame1.OptionButton1.Value = True Then
Worksheets("シートA").Range("投入範囲").Cells(a, 2).Value = Worksheets("アンケート項目").Cells(3, 2)
ElseIf Frame1.OptionButton2.Value = True Then
Worksheets("シートA").Range("投入範囲").Cells(a, 2).Value = Worksheets("アンケート項目").Cells(4, 2)

…これが続いて

ElseIf Frame1.OptionButton10.Value = True Then
Worksheets("シートA").Range("投入範囲").Cells(a, 2).Value = Worksheets("アンケート項目").Cells(12, 2)

Else
End If

…設問がQ1からQ2に変わります

If Frame2.OptionButton11.Value = True Then
Worksheets("シートA").Range("投入範囲").Cells(a, 3).Value = Worksheets("アンケート項目").Cells(3, 3)
ElseIf Frame2.OptionButton12.Value = True Then
Worksheets("シートA").Range("投入範囲").Cells(a, 3).Value = Worksheets("アンケート項目").Cells(4, 3)

…と続き

ElseIf Frame17.OptionButton240.Value = True Then
Worksheets("シートA").Range("投入範囲").Cells(a, 18).Value = Worksheets("アンケート項目").Cells(22, 18)

End Sub
までで終わります。

どうすればシンプルにコード数を減らせるでしょうか。
ご教示頂ければ幸いです。

・ツリー全体表示


	【80017】Re:VBA文字列分割

はる - 18/6/25(月) 11:40 -


	引用なし

	パスワード

hatenaさん、yさん。

ありがとうございます。
そちらのマクロも参考にさせて頂きたいと思います。

・ツリー全体表示


	【80016】Re:CTRL + TAB切り替え時にイベント発生...

亀マスター - 18/6/24(日) 22:53 -


	引用なし

	パスワード

確かにWorksheet_Activate は反応しないようですね。
ならばとWorkbook_WindowActivate も試してみましたが、やはりCtrl＋Tab での切り替えには反応しませんでした（他のエクセルブックをアクティブにしている状態から切り替えれば反応するが）。

というわけで代替案ですが、ブラウザアプリに入力したいというのであれば、IEオブジェクトを取得して、直接入力してはどうでしょうか。それなら、Ctrl＋V といった手動操作もなくなりますし、より簡単になると思います。（私はIEオブジェクトを使ったことがないので、解説はできませんが）。

参考
ht tps://www.vba-ie.net/form/text.html
ht tps://vba-code.net/ie/set-value-to-textbox/

・ツリー全体表示


	【80015】Re:上書き保存出来なくなりました。。。

γ - 18/6/24(日) 13:35 -


	引用なし

	パスワード

ありがとうございます。
共有されているブックでしたか。
共有が原因なのでしょうかね。
ほかの方の回答をおまちください。

・ツリー全体表示


	【80014】Re:上書き保存出来なくなりました。。。

サンソン

- 18/6/24(日) 1:52 -


	引用なし

	パスワード

▼γ さん：
># 既に適切解が提示されていますが。
>
>>上書き保存されない状態になっていました。
>どのようなことに基づいて、そのように判断されていますか？
>もう少し詳しく。

γ 様
お返事ありがとうございます。
下記に状況おまとめします。

1.ファイルをクリックで開く。
2.何かしらシートに書き込み、「上書き保存」を押すと、スムーズに保存されている様に見える
　（Workbook_BeforeSaveにmsgbox"セーブ前"や、Workbook_AfterSaveにmsgbox"セーブ後"を入れても表示されるので、恐らく動いているハズ。。。）
3.その後、「閉じる」を押すと、ポップアップ「保存しますか？」が表示される。
　（これもWorkbook_AfterSaveで加工しているので、理解出来る。）
4.「保存」を押そうが「保存をしない」を押そうが、次同じファイルを開くと、２や３で保存した内容が記録されておらず、１の状態で開かれる。
　（なぜ・・・？）

以上なんです。
「名前を付けて保存」した場合は書き込み内容も保存されるのですが、多ユーザーで共有のスケジュールシートなので、名前を付けて保存はしたくなくて・・・
よろしくお願いいたします。

・ツリー全体表示


	【80013】Re:上書き保存出来なくなりました。。。

サンソン

- 18/6/24(日) 1:36 -


	引用なし

	パスワード

▼よろずやさん：
>＞Workbook_BeforeSaveもWorkbook_AfterSave
>
>そんなことせんでも、
>
>＞当日の日付に色を付けて、「今日」を分かるようにしたいね。
>
>条件付き書式でできるんでは。

お世話になります！
あ、共有中でも条件付き書式って走るんですね(´･ω･｀)
てっきり動かないと思っていました。
この件が解決しなかったら、そちら試してみます。

・ツリー全体表示


	【80012】Re:上書き保存出来なくなりました。。。

γ - 18/6/23(土) 23:11 -


	引用なし

	パスワード

# 既に適切解が提示されていますが。

>上書き保存されない状態になっていました。
どのようなことに基づいて、そのように判断されていますか？
もう少し詳しく。

・ツリー全体表示


	【80011】Re:上書き保存出来なくなりました。。。

よろずや - 18/6/23(土) 22:40 -


	引用なし

	パスワード

＞Workbook_BeforeSaveもWorkbook_AfterSave

そんなことせんでも、

＞当日の日付に色を付けて、「今日」を分かるようにしたいね。

条件付き書式でできるんでは。

・ツリー全体表示


	【80010】上書き保存出来なくなりました。。。

サンソン

- 18/6/23(土) 22:11 -


	引用なし

	パスワード

お世話になります。

エクセルで複数名で使える線表の様な予定表を作っております。

作るにつれて、
・触られたくない場所はシート保護しよう。
・複数で使うブックの共有は保護の後だよね。
・当日の日付に色を付けて、「今日」を分かるようにしたいね。
・今日の色付けを、そのまま上書き保存してしまうと色が残ってしまうので、
　workbook_open()で色を付けて、記録の際はWorkbook_BeforeSaveで色を消して、Workbook_AfterSaveでもう一回色を付けよう・・・

などと作っていると・・・

いつも間にか、上書き保存を押した後そのファイルを閉じて再度開くと以前の内容が上書き保存されない状態になっていました。。（マクロの動作自体はスムーズです）
上書き保存を押した時にWorkbook_BeforeSaveもWorkbook_AfterSaveも動いているのですが・・・もちろん、Cancel=Trueなどしておりません。

VBの細かな点以前に何か大事なことが抜けている様な気がしているのですが、
お分かりになられる方おられませんでしょうか。。。

どうかよろしくお願いいたします。

・ツリー全体表示


	【80009】Re:VBA文字列分割

γ - 18/6/22(金) 22:36 -


	引用なし

	パスワード

参考出品。牛刀かもしれません。

Sub test()
　　Dim s As String, t As String
　　Dim textData
　　
　　s = "1=2 3=4 5=AAA 7=8 9=AA BB CC 10=11"

　　With CreateObject("VBScript.RegExp")
　　　　.Pattern = "(\d+=)"
　　　　.Global = True
　　　　t = .Replace(s, ",$1")
　　End With
　　textData = Split(Mid(t, 2), " ,")
　　'検証
　　Debug.Print Join(textData, vbCrLf)
End Sub

・ツリー全体表示


	【80008】Re:VBA文字列分割

hatena - 18/6/22(金) 20:01 -


	引用なし

	パスワード

解決済みですが、面白そうだったので、コード書いてみました。 Sub test2() 　　Const str = "1=2 3=4 5=AAA 7=8 9=AA BB CC 10=aa bb" 　　Dim TextData() As String 　　Dim i As Long, Pos As Long 　　TextData = Split(str, "=") 　　For i = 0 To UBound(TextData) - 2 　　　　Pos = InStrRev(TextData(i + 1), " ") 　　　　TextData(i) = TextData(i) & "=" & Left(TextData(i + 1), Pos - 1) 　　　　TextData(i + 1) = Mid(TextData(i + 1), Pos + 1) 　　Next 　　TextData(i) = TextData(i) & "=" & TextData(i + 1) 　　ReDim Preserve TextData(i) 　　'結果確認　　Debug.Print Join(TextData, vbCrLf) End Sub

・ツリー全体表示


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

122 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free