VBAの設定を最適化する方法

このQ&Aのポイント
  • VBAの設定について質問があります。
  • ExcelのVBAを利用して、特定の機能を実現したいです。
  • ExcelのVBAで、選択したセルの色を消す方法と、複数の機能を同時に動作させる方法について教えてください。
回答を見る
  • ベストアンサー

VBAの設定「2題」

最初に取り組んだEXCELのVBAですが、何人かの方にアドバイスを戴きましてやっと「まともな質問」ができる様になりました。やりたい事への完成アドバイスをお願いします。 「環境]MS Office2007(Windows10) ・ファイル名:ムービーリスト ・フィールド名:A~H、A列:NO「1からの連番で特に意味はない」、B列:タイトル名「約1300ほど」、C列:製作国、D列:ジャンル「アクション・・・他」、E列:主演、F列:実話可否「対象を(実話)と記載」、G列:アカデミー可否「対象を(アカデミー賞)と記載」、H列:内容「映画の解説」 ・該当シートにVBAを設定したい。 1,前段階で選択した色を消したい。 理由:下記の構文では選択したセルの色は変わるが、前段階で色付けたセルの色は消えない為。 Private Sub Worksheet_SelectionChange(ByVal Target As Range)   Target.Interior.ColorIndex = 6  End Sub 2,下記構文に「1」の構文をコピペして追加すると「1」で設定した機能が動作しない。※「General」→「Worksheet」、「Declaration」→「SelectionChange」の設定ができないのでコピペしました。 理由:「1」と「2」の機能を同時に動作させたい。 Private Sub Worksheet_SelectionChange(ByVal Target As Range) For Each sha In ActiveSheet.Shapes If sha.Name = "MTxt" Then sha.Delete Next ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, 1270, 80.6).Select Selection.Name = "MTxt" Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = _ "題名:" & Cells(Target.Row, 2).Value & Chr(13) & _ "内容:" & Chr(7) & Cells(Target.Row, 8).Value Target.Select End Sub 3,分からないこと 内容:下記の構文が記載されているとき、1の構文を追加したい時に「General」→「Worksheet」、「Declaration」→「SelectionChange」が選択できないので、1の構文を貼り付けていますが、正しい方法なのでしょうか。 Private Sub Worksheet_SelectionChange(ByVal Target As Range) For Each sha In ActiveSheet.Shapes If sha.Name = "MTxt" Then sha.Delete Next ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, 1270, 80.6).Select Selection.Name = "MTxt" Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = _ "題名:" & Cells(Target.Row, 2).Value & Chr(13) & _ "内容:" & Chr(7) & Cells(Target.Row, 8).Value Target.Select End Sub 以上ですが、宜しくお願いします。

質問者が選んだベストアンサー

  • ベストアンサー
  • watabe007
  • ベストアンサー率62% (476/760)
回答No.1

>前段階で選択した色を消したい。 前回選択した記録を残せば良いでしょう 使っていないと思われるZ1セルに選択の記録を残しました。 Private Sub Worksheet_SelectionChange(ByVal Target As Range)   Dim sha As Shape, strRow As Long   'どの項目を選択しても1列~8列に色付けしました。   Cells(Target.Row, 1).Resize(, 8).Interior.ColorIndex = 6   '前回選択の記録が有れば色付けを消します。   If Range("Z1").Value <> "" Then     strRow = Range("Z1").Value     Cells(strRow, 1).Resize(, 8).Interior.Pattern = xlNone   End If    'Z1セルに今回の選択行を記録します。   Range("Z1").Value = Target.Row   For Each sha In ActiveSheet.Shapes     If sha.Name = "MTxt" Then sha.Delete    Next   With ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, 1270, 80.6)     .Name = "MTxt"     .TextFrame.Characters.Text = _       "題名:" & Cells(Target.Row, 2).Value & Chr(13) & _       "内容:" & Chr(7) & Cells(Target.Row, 8).Value   End With End Sub

eokwave
質問者

お礼

watabe007 レベル12様 アクティブ行の「色変更」とアクティブセルの「内容」が、同時に実現できることを初めて知りました。「感謝」とか「感激」の言葉でお礼を申し上げたい気持ちです。しかし、私自身を振り返ってみると、VBA(Accessですが)の「複写」や「消去」の簡単なコマンドを手書きできるレベルであり、お教え頂いた構文を手直し「カスタマイズ」できる知識も力量はありません。親切(解説も付加)にアドバイス頂いているのに、レベルアップに繋げられず心苦しく思っています。今後、こうした機会(EXCELに関する質問)を多く持つことで、少しでもレベルアップ(アドバイスに報いる)したいと考えています。ありがとうございました。

関連するQ&A

  • VBAトラブル

    Sub 百人一首一番から二十番() Dim hyakuSh As Worksheet Dim mySh As Worksheet Set mySh = Worksheets("百人一首クイズ") Set hyakuSh = Worksheets("百人一首") Dim myRow As Integer Randomize myRow = Int((21 - 2 + 1) * Rnd + 2) Dim kaminoku As String Dim kaminoku2 As String Dim kaminoku3 As String Dim simonoku As String Dim simonoku1 As String Dim sakusha As String kaminoku = hyakuSh.Cells(myRow, 3).Value kaminoku2 = hyakuSh.Cells(myRow, 4).Value kaminoku3 = hyakuSh.Cells(myRow, 5).Value shimonoku = hyakuSh.Cells(myRow, 6).Value shimonoku1 = hyakuSh.Cells(myRow, 7).Value sakusha = hyakuSh.Cells(myRow, 8).Value mySh.Activate mySh.Shapes("Text Box 2").Select Selection.Characters.Text = kaminoku & Chr(10) & kaminoku2 & Chr(10) & kaminoku3 Dim MyTBox As Integer Dim smRow As Integer Dim smRow2 As Integer Dim smRow3 As Integer Dim smRow4 As Integer Dim smRow5 As Integer Dim i As Integer mySh.Shapes(2).Select Randomize smRow5 = Int((51 - 2 + 1) * Rnd + 2) Selection.Characters.Text = hyakuSh.Cells(smRow5, 6).Value & Chr(10) & hyakuSh.Cells(smRow5, 7).Value & Chr(10) & hyakuSh.Cells(smRow5, 8).Value mySh.Shapes(3).Select Randomize smRow = Int((51 - 2 + 1) * Rnd + 2) Selection.Characters.Text = hyakuSh.Cells(smRow, 6).Value & Chr(10) & hyakuSh.Cells(smRow, 7).Value & Chr(10) & hyakuSh.Cells(smRow, 8).Value mySh.Shapes(4).Select Randomize smRow2 = Int((51 - 2 + 1) * Rnd + 2) Selection.Characters.Text = hyakuSh.Cells(smRow2, 6).Value & Chr(10) & hyakuSh.Cells(smRow2, 7).Value & Chr(10) & hyakuSh.Cells(smRow2, 8).Value mySh.Shapes(5).Select Randomize smRow3 = Int((51 - 2 + 1) * Rnd + 2) Selection.Characters.Text = hyakuSh.Cells(smRow3, 6).Value & Chr(10) & hyakuSh.Cells(smRow3, 7).Value & Chr(10) & hyakuSh.Cells(smRow3, 8).Value mySh.Shapes(6).Select Randomize smRow4 = Int((51 - 2 + 1) * Rnd + 2) Selection.Characters.Text = hyakuSh.Cells(smRow4, 6).Value & Chr(10) & hyakuSh.Cells(smRow4, 7).Value & Chr(10) & hyakuSh.Cells(smRow4, 8).Value Randomize MyTBox = Int((6 - 2 + 1) * Rnd + 2) mySh.Shapes(MyTBox).Select Selection.Characters.Text = shimonoku & Chr(10) & shimonoku1 & Chr(10) & sakusha mySh.Shapes("Text Box 2").Select Dim Ans As Integer Ans = InputBox(hyakuSh.Cells(myRow, 3).Value & hyakuSh.Cells(myRow, 4).Value & hyakuSh.Cells(myRow, 5).Value & Chr(10) & Chr(10) & "下の句を番号で答えなさい", Title:="百人一首", Xpos:=7500, Ypos:=2500) If Ans = MyTBox Then MsgBox " 正解!!! V(・ o ・)V " Else MsgBox ("間違いです!!!!!!!!" & Chr(10) & Chr(10) & hyakuSh.Cells(myRow, 6).Value & hyakuSh.Cells(myRow, 7).Value & Chr(10) & Chr(10) & sakusha & "です") End If End Sub 以上のマクロをエクセルで作ったのですが、VBE~マクロを走らせると順調に走るのですが、マクロをボタンに登録すると、Inputbox に解答を掘り込んであげないと、kaminokuもshimonokuもあたらしいものになりません 今マクロはシート上にあります、マクロを標準モジュールに移しても同じ結果です。何か解決策はありますか? かなり古くエクセル2000です、初心者なので難しいこことはわかりませんが、よろしくお願いします。

  • シート上に指定した列を表示するエリアを作りたいII

    シート上に指定した列を表示するエリアを作りたいII。宜しくお願いします。 [環境]MS Office2007(Windows10) [EXCEL情報] ファイル名:ムービーリスト フィールド名:A~H A列:NO「1からの連番で特に意味はない」 B列:タイトル名「約1300ほど」 C列:製作国 D列:ジャンル「アクション・・・他」 E列:主演 F列:実話可否「対象を(実話)と記載」 G列:アカデミー可否「対象を(アカデミー賞)と記載」 H列:内容「映画の解説」 「xlsx」ファイルから「xlsm」ファイルへ保存すると「VBA」の設定が動作しません。プロセスが悪いと思いますが、結局のところ「EXCEL VBA未経験」分かっていないので解決できないでいます。以下に[解決したい内容(自身の勝手ですいません)]を2点あげております。アドバイスをお願い致します。 [解決したい内容(自身の勝手ですいません)] 1,保存後に起動するとテキストボックスは表示されるが、行を選択移動してもテキストボックスの内容が終了時のままです。 ※VBA保存時の手順「上書き保存」→「いいえ」→「EXCELマクロ有効ブック(*,xlsm)」→「保存」 2,1~5行目に作成されるテキストボックスのサイズ変更しても元に戻ってしまいます。サイズを変更する方法「固定化」を教えて下さい。 [やったこと] 1,EXCELファイルの1~5行目を空白としました。 2,操作手順:「開発」→「コードの表示」→「Sheet1(ムービー)」→「アドバイス構文」 Private Sub Worksheet_SelectionChange(ByVal Target As Range)   For Each sha In ActiveSheet.Shapes     If sha.Name = "MTxt" Then sha.Delete   Next   ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, 270, 67.5).Select   Selection.Name = "MTxt"   Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = _       "タイトル名:" & Cells(Target.Row, 2).Value & Chr(13) & _       "内容:" & Chr(13) & Cells(Target.Row, 8).Value   Target.Select End Sub 以上ですが、宜しくお願いします。

  • エクセル2003 VBAでセル移動

    いつもお世話になります。 Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Row > 9 Then If Target.Column = 3 Then Cells(Target.Row, 4).Select ElseIf Target.Column > 5 Then Cells(Target.Row + 1, 1).Select End If End If End Sub これで、B列からC列を飛ばしてD列にセル移動して取りあえずの目的は達成しているのですが、 D列からB列には方向キー移動してくれません。Target.Columnが3になるんで当たり前なんですが・・・ B列の入力ミスがあるときマウスで移動させるか、A列まで戻ってから方向キーで上に上がるかです。 何かいい方法ありませんでしょうか。D列から方向キーで戻るときも、出来ればC列を飛ばしてほしいです。 よろしくお願いします。

  • Excel VBA 数値を入れ 図形の線を変える

    図形を作成し、毎年更新をするのですが 数値を入れて、画像の線の幅を変更したいです。 下記、内容で作成したのですが、うまく動きません。 何が問題でしょうか? 数値を入れる場所は、B51になります。 Sub Macro1() ' Dim i As Integer Dim ws1 As Worksheet Set ws1 = ActiveSheet For i = 1 To 20 ActiveSheet.Shapes(ws1.Cells(50 + i, 1).Value).Select Selection.ShapeRange.Line.Weight = ws1.Cells(50 + i, 2).Value Next i End Sub

  • やはり図形のクリアで実行時エラー1004

     図形を二行三列で一枡とし図形を貼り付けていますが、どうしても実行時エラー 「1004」が出て図形のクリアができません。(尚、四角形は枠線上にあります。) 対処法がありましたらお願いします。 Windows7・SP1 Office2010 Sub 図形の貼付け() Dim i As Integer Dim j As Integer For i = 10 To 43 Step 2 For j = 9 To 99 Step 3 Select Case Cells(i, j).Value Case 1: ActiveSheet.Shapes("四角形1").Select Selection.Copy Cells(i + 1, j + 1).Select ActiveSheet.Paste Case 2: ActiveSheet.Shapes("四角形2").Select Selection.Copy Cells(i + 1, j).Select ActiveSheet.Paste Case 4: ActiveSheet.Shapes("四角形3").Select Selection.Copy Cells(i + 1, j + 1).Select ActiveSheet.Paste Case 5: ActiveSheet.Shapes("四角形3").Select Selection.Copy Cells(i + 1, j + 2).Select ActiveSheet.Paste Case 6: ActiveSheet.Shapes("円1").Select Selection.Copy Cells(i, j).Select ActiveSheet.Paste End Select Next Next End Select End Sub Sub 図形のクリア() Dim myRng As Range Set myRng = Range("I10:CW43") Dim n As Integer, sp As Variant For n = ActiveSheet.Shapes.Count To 1 Step -1 Set sp = ActiveSheet.Shapes(n) If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing  (ここで実行時エラー1004になります。) Then sp.Delete End If Next Set myRng = Nothing End Sub

  • マクロをボタンに登録するとちゃんと走らない

    エクセル2000で以下のような百人一首のマクロを作ったのですが マクロをボタンに登録すると上の句と下の句の更新が後回しになります VBEを開いたままマクロを実行すると上の句下の句を更新したあとに 解答用のinputboxがちゃんと先に出てきます。 何か解決方法はありますか? マクロを作ったのは初めてに近いです あとマクロコードを2行にするのが出きるときと出来ない時があるのは 何故でしょう。同じように _ アンダーバーを入れて改行してるのですが エラーになります。改行して良い所と悪い所があるのですか 教えて欲しいです。 Sub 百人一首一番から二十番() Dim hyakuSh As Worksheet Dim mySh As Worksheet Set mySh = Worksheets("百人一首クイズ") Set hyakuSh = Worksheets("百人一首") Dim myRow As Integer Randomize myRow = Int((21 - 2 + 1) * Rnd + 2) Dim kaminoku As String Dim kaminoku2 As String Dim kaminoku3 As String Dim simonoku As String Dim simonoku1 As String Dim sakusha As String kaminoku = hyakuSh.Cells(myRow, 3).Value kaminoku2 = hyakuSh.Cells(myRow, 4).Value kaminoku3 = hyakuSh.Cells(myRow, 5).Value shimonoku = hyakuSh.Cells(myRow, 6).Value shimonoku1 = hyakuSh.Cells(myRow, 7).Value sakusha = hyakuSh.Cells(myRow, 8).Value mySh.Activate mySh.Shapes("Text Box 2").Select Selection.Characters.Text = kaminoku & Chr(10) & kaminoku2 & Chr(10) & kaminoku3 Dim MyTBox As Integer Dim smRow As Integer Dim smRow2 As Integer Dim smRow3 As Integer Dim smRow4 As Integer Dim smRow5 As Integer Dim i As Integer mySh.Shapes(2).Select Randomize smRow5 = Int((51 - 2 + 1) * Rnd + 2) Selection.Characters.Text = hyakuSh.Cells(smRow5, 6).Value & Chr(10) & hyakuSh.Cells(smRow5, 7).Value & Chr(10) & hyakuSh.Cells(smRow5, 8).Value mySh.Shapes(3).Select Randomize smRow = Int((51 - 2 + 1) * Rnd + 2) Selection.Characters.Text = hyakuSh.Cells(smRow, 6).Value & Chr(10) & hyakuSh.Cells(smRow, 7).Value & Chr(10) & hyakuSh.Cells(smRow, 8).Value mySh.Shapes(4).Select Randomize smRow2 = Int((51 - 2 + 1) * Rnd + 2) Selection.Characters.Text = hyakuSh.Cells(smRow2, 6).Value & Chr(10) & hyakuSh.Cells(smRow2, 7).Value & Chr(10) & hyakuSh.Cells(smRow2, 8).Value mySh.Shapes(5).Select Randomize smRow3 = Int((51 - 2 + 1) * Rnd + 2) Selection.Characters.Text = hyakuSh.Cells(smRow3, 6).Value & Chr(10) & hyakuSh.Cells(smRow3, 7).Value & Chr(10) & hyakuSh.Cells(smRow3, 8).Value mySh.Shapes(6).Select Randomize smRow4 = Int((51 - 2 + 1) * Rnd + 2) Selection.Characters.Text = hyakuSh.Cells(smRow4, 6).Value & Chr(10) & hyakuSh.Cells(smRow4, 7).Value & Chr(10) & hyakuSh.Cells(smRow4, 8).Value Randomize MyTBox = Int((6 - 2 + 1) * Rnd + 2) mySh.Shapes(MyTBox).Select Selection.Characters.Text = shimonoku & Chr(10) & shimonoku1 & Chr(10) & sakusha mySh.Shapes("Text Box 2").Select Dim Ans As Integer *以下の部分が先に出てきて答えを入れないと上のコードが実行されない* ****ここ一行で書いてあるので見にくい部分******* Ans = InputBox(hyakuSh.Cells(myRow, 3).Value & hyakuSh.Cells(myRow, 4).Value & hyakuSh.Cells(myRow, 5).Value & Chr(10) & Chr(10) & "下の句を番号で答えなさい", Title:="百人一首", Xpos:=7500, Ypos:=2500) ********************************* If Ans = MyTBox Then MsgBox " 正解!!! V(・ o ・)V " Else MsgBox ("間違いです!!!!!!!!" & Chr(10) & Chr(10) & hyakuSh.Cells(myRow, 6).Value & hyakuSh.Cells(myRow, 7).Value & Chr(10) & Chr(10) & sakusha & "です") End If End Sub

  • エクセルVBAの記述方法の質問です。

    エクセルです。12個のセルの文字列をオートシェープの吹き出しに順に表示させるマクロをつくりました。 Sub tenki2() Dim i As Integer Dim a As String For i = 1 To 12 a = Cells(i, 2).Value ActiveSheet.Shapes("AutoShape 4").Select Selection.Characters.Text = a Application.Wait Now + TimeValue("00:00:05") Next i End Sub これで思った通り表示されるのですが、できればオートシェープをセレクトしないようにしたいのです。 (シートを保護するため) それで ActiveSheet.Shapes("AutoShape 4").Select Selection.Characters.Text = a のところを ActiveSheet.Shapes("AutoShape 4").Characters.Text = a と変えたのですが、「オブジェクトはこのプロパティまたはメソッドをサポートしていません」という実行時エラーがでてしまいました。書き方のどこがまずかったのでしょうか?ご教示いただければ幸いです。

  • Excel 2010 で勤務割表を作成しています。

    月間の勤務割表を作成しています。 3列3行を一枡として一人・一日の枡とし、勤務の割り振り状態を表示するものです。 列に日付、行を個人名(max16名)としますから、3列3行の枡が496個となります。 各枡とも1列目の1行目に勤務種別コード(1~5)を記述し、このコードNoにより4種の図形を貼付けています。 1つ1つの枡(496個)に以下のコードを書き実行しています。膨大な行数を要します。 使用するパソコンにおいては実行速度がかなりかかります。 これをもっと単純化する手法についてご教示いただければ幸いです。 Sub Macro1() Select Case Range("I6").Value '1人目-1日 Case 1: ActiveSheet.Shapes("四角形1").Select Selection.Copy Range("J7").Select ActiveSheet.Paste Case 2: ActiveSheet.Shapes("四角形2").Select Selection.Copy Range("I7").Select ActiveSheet.Paste Case 3: ActiveSheet.Shapes("四角形3").Select Selection.Copy Range("J7").Select ActiveSheet.Paste Case 4: ActiveSheet.Shapes("直線1").Select Selection.Copy Range("I6").Select ActiveSheet.Paste Case 9: ActiveSheet.Shapes("四角形3").Select Selection.Copy Range("J7").Select ActiveSheet.Paste End Select  '|   '| <同じことを一つ一つの枡ごとに繰り返し記述しています。>   '| Select Case Range("CU51").Value '16人目-31日 Case 1: ActiveSheet.Shapes("四角形1").Select Selection.Copy Range("CV52").Select ActiveSheet.Paste Case 2: ActiveSheet.Shapes("四角形2").Select Selection.Copy Range("CU52").Select ActiveSheet.Paste Case 3: ActiveSheet.Shapes("四角形3").Select Selection.Copy Range("CV52").Select ActiveSheet.Paste Case 4: ActiveSheet.Shapes("直線1").Select Selection.Copy Range("CU51").Select ActiveSheet.Paste Case 9: ActiveSheet.Shapes("四角形3").Select Selection.Copy Range("CV52").Select ActiveSheet.Paste End Select End Sub

  • VBAについて教えて下さい。

    エクセル2003を使用してます。 ("Sheet1")のB列をダブルクリックすると、 ("Sheet2")の("AA100")を表示するようにしたいのですが、 ■の部分がエラーが出て、色々変更して試してるのですが駄目です。 どう言う風に、書けばいいのかわかりません。 どなたか教えて頂けませんか? 下記VBAです。 ──────────────────────────────── Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Cells.Count > 1 Then Exit Sub If Target.Column <> 2 Then Exit Sub Sheets("Sheet2").Activate ■Range("AA100").Select End Sub ──────────────────────────────── よろしくお願いします。

  • EXCEL VBA これであっていますか?

    エクセルに地図を貼り付け、その中のある地点Aから半径1キロ、2キロ、3キロといった具合に円を描いています。ある地点B、Cも同様に円があります。セルに“A” と入力した際に該当する地点の円(1キロ、2キロ、3キロの3種類)を赤く表示し、終了すると円が消える(線なしに変わる)ようにするために以下のようなVBAを組みました。が、円が2つしか赤くならなかったり、 ばあいによっては「インデックスが境界を超えています」とエラーが出たりします。 どうしたら良いか教えてください。 Sub iro() Dim i As Variant i = InputBox("表示する地点を指定してください", "地点指定") If i = "A" Then ActiveSheet.Shapes(1).Select ActiveSheet.Shapes(2).Select ActiveSheet.Shapes(3).Select Replace:=False hyoji MsgBox "表示を終了してよろしいですか", vbOKOnly ActiveSheet.Shapes(1).Select ActiveSheet.Shapes(2).Select ActiveSheet.Shapes(3).Select Replace:=False modosu ElseIf i = "B" Then ActiveSheet.Shapes(4).Select ActiveSheet.Shapes(5).Select ActiveSheet.Shapes(6).Select Replace:=False hyoji MsgBox "表示を終了してよろしいですか", vbOKOnly ActiveSheet.Shapes(4).Select ActiveSheet.Shapes(5).Select ActiveSheet.Shapes(6).Select Replace:=False Else MsgBox "指定した地点がありません", vbOKOnly End If End Sub Sub hyoji() Selection.ShapeRange.Line.Visible = msoTrue '「線なし」に設定されている場合、線を表示 Selection.ShapeRange.Line.ForeColor.SchemeColor = 10 Range("A1").Select End Sub Sub modosu() Selection.ShapeRange.Line.Visible = msoFalse '「線なし」に設定 Range("A1").Select End Sub

専門家に質問してみよう