- ベストアンサー
EXCELmacroについて
hawa254の回答
- hawa254
- ベストアンサー率43% (259/589)
今後、このマクロの改版や流用がないなら、そのままでいいと思います。 改版や流用があるなら、少しわかりずらいコーディングになっているので、別Procにした方が、保守性が良くなると思います。
関連するQ&A
- Excel VBA で1時的に右クリックを使いたい
30枚ほどのシートの表を一挙に変更したいです。ところが、各シートに次のコードが入っているため、右クリックしてコピーとか一切使えません。各シートの変更ができるまで、右クリック使いたいです。何か方法ありませんでしょうか？ ' 画面の一番上表示 Dim hr As Range Set hr = Range("A1") '左上隅セルを設定 ActiveWindow.ScrollRow = hr.Row '行の一番上にスクロール ActiveWindow.ScrollColumn = hr.Column '列の一番左にスクロール End Sub Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) Cancel = True 'プロシージャ終了後に表示されるショートカットメニューの非表示 If Target.Row > 14 And Target.Row < 45 And Target.Column > 13 And Target.Column < 15 Then 明細入力フォーム.Show End If If Target.Row > 36 And Target.Row < 45 And Target.Column > 1 And Target.Column < 3 Then Call ShowCalendarFromRange2(Target) End If If Target.Row > 36 And Target.Row < 45 And Target.Column > 3 And Target.Column < 5 Then Call ShowCalendarFromRange2(Target) End If If Target.Row > 36 And Target.Row < 45 And Target.Column > 5 And Target.Column < 7 Then Call ShowCalendarFromRange2(Target) End If If Target.Row > 36 And Target.Row < 45 And Target.Column > 8 And Target.Column < 10 Then Call ShowCalendarFromRange2(Target) End If If Target.Row > 36 And Target.Row < 45 And Target.Column > 2 And Target.Column < 4 Then UserForm3.Show End If If Target.Row > 36 And Target.Row < 45 And Target.Column > 4 And Target.Column < 6 Then UserForm3.Show End If If Target.Row > 36 And Target.Row < 45 And Target.Column > 6 And Target.Column < 8 Then UserForm3.Show End If If Target.Row > 36 And Target.Row < 44 And Target.Column > 9 And Target.Column < 11 Then UserForm3.Show End If End Sub
- ベストアンサー
- Excel（エクセル）
- VBAのキー入力待ちでCPU負荷大
VBAでキー入力待ちで動作をするプログラムを組んでいますが、 プログラムの組み方が悪くCPUの負荷が高くなり、CPUの温度が かなり上がってしまいます。 いろいろ調べたのですがわかりません。 負荷を下げるプログラムの書き方を教えていただけないでしょうか。 Excel2010です。 よろしくお願いします。 Sub ボタン1_Click() Dim i, j, k, Maxrow, Colst, colen, nCnt As Integer Do Until GetAsyncKeyState(27) If GetAsyncKeyState(75) <> 0 Then ・ ・ 「モジュールプログラム1」 ・ ・ Do Until GetAsyncKeyState(75) = 0 Loop ElseIf GetAsyncKeyState(77) <> 0 Then ・ ・ 「モジュールプログラム2」 ・ ・ Do Until GetAsyncKeyState(77) = 0 Loop ElseIf GetAsyncKeyState(37) <> 0 Then If ActiveCell.Column > 1 Then ActiveCell.Offset(0, -1).Activate End If ElseIf GetAsyncKeyState(38) <> 0 Then If ActiveCell.Row > 1 Then ActiveCell.Offset(-1, 0).Activate End If ElseIf GetAsyncKeyState(39) <> 0 Then ActiveCell.Offset(0, 1).Activate ElseIf GetAsyncKeyState(40) <> 0 Then ActiveCell.Offset(1, 0).Activate End If For k = 1 To 300: Next k Loop Sheets("Main").Activate End Sub
- ベストアンサー
- Visual Basic
- excel vba ジャンプ
excel2003のUserFormにてtextbox作成しました。 textbox1にページを入力すると指定のページにジャンプする コードを作成したのですが、動作的には目的とする事ができました。 ただ、初心者レベルで作成したので、コード記述が長く、 ページが増えるたびにコードを追記していかなければなりません。 下記に作成したコードを記述します。 もっと簡単に記述する方法はありますか？ ---------------------------------------------------------- Private Sub TextBox1_Change() If TextBox1.Value = 1 Then ActiveWindow.ScrollRow = 1 ActiveWindow.ScrollColumn = 1 Range("$A$15").Select End If If TextBox1.Value = 2 Then ActiveWindow.ScrollRow = 38 ActiveWindow.ScrollColumn = 1 Range("$A$38").Select End If If TextBox1.Value = 3 Then ActiveWindow.ScrollRow = 69 ActiveWindow.ScrollColumn = 1 Range("$A$69").Select End If If TextBox1.Value = 4 Then ActiveWindow.ScrollRow = 100 ActiveWindow.ScrollColumn = 1 Range("$A$100").Select End If If TextBox1.Value = 5 Then ActiveWindow.ScrollRow = 131 ActiveWindow.ScrollColumn = 1 Range("$A$131").Select End If End Sub ---------------------------------------------------------- 上記記述で行っていることは、 textbox1に 1 と入力すると1ページ目が表示 キーボードでctrl+Homeの操作をした状態でカーソルがA15選択 textbox1に 2 と入力すると2ページ目が表示 表示の先頭が38行目、カーソルがA38選択 ページの行数が1ページ目だけ37行 2ページ目以降が31行ごとです。 実際は、200ページ以上あるのでなんとかしたいのですが・・・・
- ベストアンサー
- オフィス系ソフト
- エクセルで行を非表示にするとアクティブなセルが・・・
エクセルで行を非表示にするとアクティブなセル？行？がどこかわからなくなり、マクロでアクティブなセルを移動するときにエラーが出ます。 Sub example() ActiveSheet.Range("D3").Select Do Until ActiveCell = 23 If ActiveCell <> "" Then ActiveCell.Offset(1, 0).Select ElseIf ActiveCell <> "" Then ActiveCell.Offset(1, -3).Select ElseIf ActiveCell <> "" Then ActiveCell.Offset(1, -6).Select Else: ActiveCell.EntireRow.Select Selection.EntireRow.Hidden = True ActiveCell.Offset(0, -6).Select End If Loop End Sub 一番下のActiveCell.Offset(0, -6).Select にエラーが出るのですが、どうすればセルを移動できるでしょうか？
- ベストアンサー
- オフィス系ソフト
- エクセルのマクロでセル選択の条件式の書き方
いつもお世話になりありがとうございます。 Excel97です。 Worksheet_SelectionChangeマクロで、 Range("B2:D11")内のセルが選択されたときに動くマクロを書きたいのですが、条件式を With ActiveCell If .Row < 12 And .Row > 1 And .Column < 5 And .Column > 1 Then '実行するマクロ End If End With とIfの行を And、And、And で長々と書かず、Range("B2:D11")を使うなりしてもっと簡略な記述方法はないでしょうか？ ご教示いただければ幸いです。
- ベストアンサー
- オフィス系ソフト
- エクセルVBAで無限ループ
教えてください。 以下の２つのエクセルマクロはまったく同じことをさせようとしているのですが、test02の方は.Offset(1).Activateが働かないのか、無限ループに陥ってしまいます。 単にActiveCell.という記述をWith～End Withでまとめただけなのになぜこうなるのでしょうか？ Sub test01() ActiveSheet.Cells(1, 1).Activate Do While ActiveCell.Value <> "" If Not IsNumeric(ActiveCell.Value) Then ActiveCell.Offset(0, 1).Value = "文字" ElseIf ActiveCell.Value > 0 Then ActiveCell.Offset(0, 1).Value = "正数" ElseIf ActiveCell.Value < 0 Then ActiveCell.Offset(0, 1).Value = "負数" Else ActiveCell.Offset(0, 1).Value = "その他" End If ActiveCell.Offset(1).Activate i = i + 1 Application.StatusBar = i Loop End Sub Sub test02() ActiveSheet.Cells(1, 1).Activate With ActiveCell Do While .Value <> "" If Not IsNumeric(.Value) Then .Offset(0, 1).Value = "文字" ElseIf .Value > 0 Then .Offset(0, 1).Value = "正数" ElseIf ActiveCell.Value < 0 Then .Offset(0, 1).Value = "負数" Else .Offset(0, 1).Value = "その他" End If .Offset(1).Activate i = i + 1 Application.StatusBar = i Loop End With End Sub
- ベストアンサー
- オフィス系ソフト
- ダブルクリック 条件 分岐
こんばんは ＶＢＡの勉強をはじめたばかりの素人です。 いろいろ調べたのですが自分の学習不足もあってかなかなか 回答に結びつかなかったので質問させてください。 シートの("A:A")をダブルクリックしたらフォーム１を表示する シートの("B:B")をダブルクリックしたらフォーム２を表示する シートの("C:C")をダブルクリックしたらフォーム３を表示する といった簡単なイベントなのですがうまくできません。 '----------------------------------------------- Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If ActiveCell.Address = ("A:A") Then 1.Show ElseIf ActiveCell.Address = ("B:B") Then 2.Show ElseIf ActiveCell.Address = ("C:C") Then 3.Show End If End Sub '----------------------------------------------- 又は '----------------------------------------------- Private Sub Workbook_Open() ActiveWorkbook.Worksheets("Sheet1").OnDoubleClick = "Test" End Sub Public Sub Test() A列 = 1 B列 = 2 C列 = 3 現在位置列 = ActiveCell.Column 現在位置行 = ActiveCell.Row Select Case ActiveCell.Address Case 現在位置列 = A列 1.Show Case 現在位置列 = B列 2.Show Case 現在位置列 = C列 3.Show End Select End Sub '----------------------------------------------- などがが今の私ができる最大限の内容ですが、全く違うようです。 素人質問で大変申し訳ありません。 勘違いが多々あるかもしれませんが教えてください。 以上宜しくお願いいたします。
- ベストアンサー
- Visual Basic
- VBAで特定の文字が含まれている画像ファイル
下記コードで画像の貼り付けを行っていますが 現在は適当な順番で貼り付けが行われます。 Declare Function SetCurrentDirectory Lib "kernel32" Alias _ "SetCurrentDirectoryA" (ByVal CurrentDir As String) As Long Sub ShapeLoadtest() Dim Fname As Variant, fe As Variant Dim Fn As Variant, Pic As Shape Dim pno As Long Dim myFileName As String Dim strFileName As String Range("B4").Select SetCurrentDirectory "C:\Users\yuya\Desktop\画像\" Fname = Application.GetOpenFilename _ (",*", MultiSelect:=True) If Not IsArray(Fname) Then MsgBox "取り消されました。", vbInformation Exit Sub End If Application.ScreenUpdating = False pno = 0 For Each Fn In Fname 'この次へ追加すべき行 Selection.Offset(-1, 0) = Mid(Fn, InStrRev(Fn, "\") + 1, Len(Fn) - InStrRev(Fn, "\")) ActiveCell.Select Set Pic = ActiveSheet.Shapes.AddPicture(Filename:=Fn, _ LinkToFile:=False, _ SaveWithDocument:=True, _ Left:=0, Top:=0, Width:=0, Height:=0) With Pic .ScaleWidth 1, msoTrue .ScaleHeight 1, msoTrue .Top = ActiveCell.Top ' 位置：アクティブセルの上側に重ねる .Left = ActiveCell.Left ' 位置：アクティブセルの左側に重ねる .Placement = xlMove ' 移動するがサイズ変更しない End With If ActiveCell.Column = 2 Then ActiveCell.Offset(, 8).Select ElseIf ActiveCell.Column = 10 Then ActiveCell.Offset(, 8).Select ElseIf ActiveCell.Column = 18 Then ActiveCell.Offset(32, -16).Select End If Set Pic = Nothing pno = pno + 1 Next Application.ScreenUpdating = True Range("A1").Select MsgBox pno & "枚の画像を挿入しました", vbInformation End Sub これを画像ファイル名に【あいう】という文字が混じっていたら If ActiveCell.Column = 2 Then ActiveCell.Offset(, 8).Select のセルに 【１２３】という数字が混じっていたら ElseIf ActiveCell.Column = 10 Then ActiveCell.Offset(, 8).Select のセルに貼り付けという具合にしたいです。 よろしくお願いします。
- ベストアンサー
- Excel（エクセル）
- エクセルVBAについて質問です
お世話になります。 早速ですが、下記の構文を作成しましたが、Activecell.Rowの部分で悪さをし 上手く動きません。 行いたかった事としては、Functionにて関数を手作りしようと試みたのですが、 結局は壁にぶちあたってしまったって所です。。。 内容としては、エクセルが手動計算だった場合は、一回りで動作が終了するので 問題なく想定の値が叩き出されますが、自動計算にした途端に「別セルに入れた 計算式まで、Activecell.Rowに引きずられて計算をし、別の値に変わってしまう」 現象となってしまいました。。。（説明下手で済みません） Public Function Shotoku(houshu As Long) Dim ACcel As Variant Dim FR As Range With Worksheets("所得税月額表（平成24年分）") ACcel = houshu If ACcel < 88000 Then Shotoku = 0 Exit Function End If For Each FR In .Range("C13:C347") If ACcel < FR Then If Cells(ActiveCell.Row, 51) = 0 Then ←問題の個所です Shotoku = .Cells(FR.Row, 4) ElseIf Cells(ActiveCell.Row, 51) = 1 Then ←問題の個所です Shotoku = .Cells(FR.Row, 5) ElseIf Cells(ActiveCell.Row, 51) = 2 Then ←問題の個所です Shotoku = .Cells(FR.Row, 6) ElseIf Cells(ActiveCell.Row, 51) = 3 Then ←問題の個所です Shotoku = .Cells(FR.Row, 7) ElseIf Cells(ActiveCell.Row, 51) = 4 Then ←問題の個所です Shotoku = .Cells(FR.Row, 8) ElseIf Cells(ActiveCell.Row, 51) = 5 Then ←問題の個所です Shotoku = .Cells(FR.Row, 9) ElseIf Cells(ActiveCell.Row, 51) = 6 Then ←問題の個所です Shotoku = .Cells(FR.Row, 10) ElseIf Cells(ActiveCell.Row, 51) = 7 Then ←問題の個所です Shotoku = .Cells(FR.Row, 11) End If Exit For End If Next End With End Function 計算式を当て込んで、例えば２行目のIF文の条件に引っかかった場合、他の セルまでその行を読んでしまうので、条件が変わってしまう事態になってます。 イメージではActivecell.Rowがダメなんだと思いますが、これ以外のセル番地の 取得方法が分からなくって＞＜； どなたかお助け願います！！！
- ベストアンサー
- その他MS Office製品
- シングルクリックでフォームが表示されない
windowsＸＰ Ｅｘｃｅｌ2000 でマクロを作成している超初心者です。 あるサイトの暦で日付を入力するマクロですが、１枚のシートに 1）と 2）を併記して実験したところ正常に表示できました。 2）をシングルクリックで表示したいのですができません。なぜでしょうか？ 2）はいかにも稚拙です。もっと整理したいのですが方法が分かりません。以上２点よろしくご指導ください。 -------------------------------------------------------------------- １）シングルクリックで UserForm1を正常に起動できました。 Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'シングルクリックで表示 Cancel = True 'プロシージャ終了後に表示されるショートカットメニューの非表示 If Target.Row > 22 And Target.Column > 2 And Target.Column < 4 Then UserForm1.Show End If If Target.Row > 22 And Target.Column > 13 And Target.Column < 15 Then UserForm1.Show End If End Sub ------------------------------------------------------------------------- 2）ダブルクリックでしか正常に表示されません。 'Private Sub Worksheet_SelectionChange(ByVal Target As Range)’ 起動しない Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) '起動した Cancel = True 'プロシージャ終了後に表示されるショートカットメニューの非表示 If Target.Row > 23 And Target.Column > 1 And Target.Column < 3 Then Call ShowCalendarFromRange2(Target) End If If Target.Row > 23 And Target.Column > 12 And Target.Column < 14 Then Call ShowCalendarFromRange2(Target) End If If Target.Row > 12 And Target.Row < 21 And Target.Column > 12 And Target.Column < 14 Then Call ShowCalendarFromRange2(Target) End If If Target.Row > 12 And Target.Row < 21 And Target.Column > 14 And Target.Column < 16 Then Call ShowCalendarFromRange2(Target) End If If Target.Row > 12 And Target.Row < 21 And Target.Column > 16 And Target.Column < 18 Then Call ShowCalendarFromRange2(Target) End If If Target.Row > 12 And Target.Row < 21 And Target.Column > 18 And Target.Column < 20 Then Call ShowCalendarFromRange2(Target) End If End Sub ----------------------------------------------------------------------- 3）'これがサイトにあった例で、これを元に上のスクリプトを作りました。 'Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' 複数セル選択時は無視 ' If Target.Count <> 1 Then Exit Sub ' A列以外は無視(今回サンプルの例) ' If Target.Column <> 1 Then Exit Sub ' カレンダーフォームを起動する ' Call ShowCalendarFromRange2(Target) 'End Sub ---------------------------------------------------------------
- ベストアンサー
- Visual Basic
お礼
>少しわかりずらいコーディングになっている ですよね。。。解り難いですよね？他の回答も参考に解り易くなるよう変えてみます。ありがとうございます。