砂時計のクリックしないと矢印に戻らない問題の解決方法
- 処理終了後のに砂時計が、クリックしないと矢印に戻りません。自分のパソコンでは、クリックしないで戻るのですが。会社のパソコンだとできません。スッペクの良し悪しなのか、スペックに関係なくクリックしないで矢印に戻る解決方法があればお願いします。
- Windows7 Office2010を使用しています。
- Private Sub 定義の書込_Click() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim ret As Integer ret = MsgBox("メインシートのデータを、" & ActiveSheet.Range("C54").Value & "の勤務表に" _ & "書き込みます。 よろしいですか？", _ vbOKCancel + vbQuestion, "メイン・2")
- ベストアンサー
処理終了後のに砂時計が、クリックしないと矢印に
高速処理ができるようにしたのはいいのですが、マウスポインタの砂時計がクリックしないと矢印に戻りません。自分のパソコンでは、クリックしないで戻るのですが。会社のパソコンだとできません。スッペクの良し悪しなのか、スペックに関係なくクリックしないで矢印に戻る解決方法があればお願いします。(コードは下記です。) Windows7 Office2010 Private Sub 定義の書込_Click() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim ret As Integer ret = MsgBox("メインシートのデータを、" & ActiveSheet.Range("C54").Value & "の勤務表に" _ & "書き込みます。 よろしいですか？", _ vbOKCancel + vbQuestion, "メイン・2") Select Case ret Case vbOK UserForm2.Show vbModeless UserForm2.Repaint Dim i As Integer Dim j As Integer For i = 1 To 16 For j = 1 To 31 Dim addrname_workpattern As String addrname_workpattern = "" With Worksheets("メイン") Select Case .Cells(9 + (i - 1) * 2, 10 + (j - 1) * 3).Value Case 1: addrname_workpattern = "勤務1" Case 2: addrname_workpattern = "勤務2" Case 3: addrname_workpattern = "勤務3" Case 4: addrname_workpattern = "日勤1" Case 5: addrname_workpattern = "日勤2" Case 6: addrname_workpattern = "日勤3" Case Else Select Case .Cells(10 + (i - 1) * 2, 9 + (j - 1) * 3).Value Case 1: addrname_workpattern = "日勤4" Case Else Select Case .Cells(9 + (i - 1) * 2, 9 + (j - 1) * 3).Value Case 2: addrname_workpattern = "明け" Case 3: addrname_workpattern = "日勤" Case 4: addrname_workpattern = "夜勤" Case 5: addrname_workpattern = "公" Case 6: addrname_workpattern = "有" Case 7: addrname_workpattern = "特" Case 8: addrname_workpattern = "振" Case 9: addrname_workpattern = "欠" End Select End Select End Select End With If addrname_workpattern <> "" Then ActiveSheet.Range(addrname_workpattern).Copy Cells(7 + i, 5 + (j - 1) * 3).PasteSpecial Application.CutCopyMode = False End If Next Next Unload UserForm2 Range("E10:CS10").Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Range("E34:CS34").Select Selection.Delete Shift:=xlUp Macro9 Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Select End Sub
- Rord
- お礼率67% (25/37)
- Visual Basic
- 回答数1
- ありがとう数1
- みんなの回答 （1）
- 専門家の回答
質問者が選んだベストアンサー
最後に以下の処理を入れてみては如何でしょうか。 Application.Cursor = xlDefault
関連するQ&A
- 処理を1行飛ばして実行
月間の勤務割表を作成しています。 1列3行を一枡として一人・一日の枡とし、勤務の割り振り状態を表示するものです。 列に日付、行を個人名（max16名）とし1列3行を名前の定義で15種類作成してあります。 同じシートの各セルの入力番号(2行3列を一升)でに応じて15種類を貼り付けていますが、下記のコードで特定行(E10:CS10)を一行飛ばして処理をすることは可能でしょうか？ご享受お願いします。 Windows7 Office2010 Private Sub 定義の書込_Click() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim ret As Integer ret = MsgBox("メインシートのデータを元に、" & ActiveSheet.Range("C54").Value & "の勤務表を" _ & "作成します。 よろしいですか？ 少しお待ちください。", _ vbOKCancel + vbQuestion, "メイン・2") Dim i As Integer Dim j As Integer For i = 1 To 16 For j = 1 To 31 Dim addrname_workpattern As String addrname_workpattern = "" With Worksheets("メイン") Select Case .Cells(9 + (i - 1) * 2, 10 + (j - 1) * 3).Value Case 1: addrname_workpattern = "勤務1" Case 2: addrname_workpattern = "勤務2" Case 3: addrname_workpattern = "勤務3" Case 4: addrname_workpattern = "日勤1" Case 5: addrname_workpattern = "日勤2" Case 6: addrname_workpattern = "日勤3" Case Else Select Case .Cells(10 + (i - 1) * 2, 9 + (j - 1) * 3).Value Case 1: addrname_workpattern = "AC" Case 2: addrname_workpattern = "研修" Case Else Select Case .Cells(9 + (i - 1) * 2, 9 + (j - 1) * 3).Value Case 2: addrname_workpattern = "明け" Case 3: addrname_workpattern = "日勤" Case 4: addrname_workpattern = "夜勤" Case 5: addrname_workpattern = "公" Case 6: addrname_workpattern = "有" Case 7: addrname_workpattern = "特" Case 8: addrname_workpattern = "振" Case 9: addrname_workpattern = "欠" End Select End Select End Select End With If addrname_workpattern <> "" Then ActiveSheet.Range(addrname_workpattern).Copy Cells(7 + i, 5 + (j - 1) * 3).PasteSpecial Application.CutCopyMode = False End If Next Next Range("E10:CS10").Select (今は、行の挿入・削除で対応しています。） Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Range("E34:CS34").Select Selection.Delete Shift:=xlUp Range("E8").Select Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.Cursor = xlDefault End Sub
- ベストアンサー
- Visual Basic
- やはり図形のクリアで実行時エラー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
- ベストアンサー
- Visual Basic
- マクロの処理速度が遅くなってしまいました
今までエクセル２０００を使用していたのですが、エクセル２００３にバージョンアップして、以下の処理速度を検証したところ、処理が遅くなってしまいました。内容はsheet2にあるデータを変数に格納して簡単な計算をした後にsheet1に入力するということを5回繰り返し、それぞれの処理にかかる時間をsheet3に表示するというものです。 Sub タイム計測() Dim myStart As Single, myGoal As Single Dim j As Integer Application.ScreenUpdating = False Sheets(1).Select Cells.Clear For j = 1 To 5 myStart = Timer Call サンプル myGoal = Timer - myStart Sheets(3).Select Cells(j, 1) = myGoal Sheets(1).Select Next Sheets(3).Select Application.ScreenUpdating = True End Sub Sub サンプル() Dim i As Integer, j As Integer Dim Data As Variant, KeKKa(1 To 2000, 1 To 199) As Variant Data = Range(Sheets(2).Cells(1, 1), Sheets(2).Cells(2000, 199)) For i = 1 To 2000 For j = 1 To 199 KeKKa(i, j) = Data(i, j) + Data(i, j) Next Next Range(Cells(1, 1), Cells(2000, 199)) = KeKKa End Sub エクセル２０００のときは1回当り平均して概ね0.7秒位で処理していたのですが、エクセル２００３にすると1.4秒位かかってしまいます。処理速度が遅くなってしまうとバージョンアップした意味がないのですが、原因や改善策があればどなたか教えていただけないでしょうか？よろしくお願いします。
- ベストアンサー
- Visual Basic
- マクロが実行しない
二行三列を一枡として月の勤務割表を作成しています。マクロで同じ事を しているのにMacro1の方が実行しません。お教え願えませんでしょうか。 (尚、図形を枠線上にコピペしています。) Sub Macro1()実行しません。 Dim i As Integer Dim j As Integer For i = 10 To 43 Step 2 For j = 10 To 103 Step 3 Select Case Cells(i, j).Value Case 1: ActiveSheet.Shapes("四角形1").Select Selection.Copy Cells(i + 1, j + 1).Select ActiveSheet.Paste End Select Next Next End Sub Sub Macro2()実行します。 ActiveSheet.Shapes.Range(Array("四角形1")).Select Selection.Copy Range("J11:K11").Select ActiveSheet.Paste End Sub
- ベストアンサー
- Visual Basic
- 印刷プレビュー表示後ユーザーフォームが閉じません。
下記のコードで印刷プレビューが表示された後,UserForm3が閉じるようにしてありましたができなくなりました。プレビューの閉じるボタンをクリックするとUserForm3一緒に閉じます。解決策がありましたらお願いします。勉強不足でわかりませんので。 Sub 印刷範囲() Application.ScreenUpdating = False Dim ret As Integer ret = MsgBox("印刷範囲を、" & ActiveSheet.Range("B59").Value & "勤務表上に" _ & "表示します。 よろしいですか？", _ vbOKCancel + vbQuestion, "メイン処理") Select Case ret Case vbOK UserForm3.Show vbModeless UserForm3.Repaint With Worksheets("メイン") .PageSetup.CenterHorizontally = True .PageSetup.CenterVertically = True .PrintPreview End With Unload UserForm3 End Select Application.ScreenUpdating = True End Sub
- ベストアンサー
- Visual Basic
- ＶＢＡ超初心者です
皆さんのお知恵を拝借させてください。 Sub Macro1() ' ' Macro1 Macro ' マクロ記録日 : 2007/12/1 ユーザー名 : 101 ' Dim pearend As Integer Dim code As Integer Dim codeend As Integer Dim sheet_name As String Dim dayend As Date Sheets("商品名").Select Range("A4").Select Selection.End(xlDown).Select pearend = Selection.Row() For l = 4 To pearend Step 2 For r = 2 To 3 Cells(l, r).Select code = Cells(l, r).Value Select Case code Case 1000 To 1999 sheet_name = "1000" Case 2000 To 2999 sheet_name = "2000" Case 3000 To 3999 ssheet_name = "3000" Case 4000 To 4999 sheet_name = "4000" Case 5000 To 5999 sheet_name = "5000" End Select Sheets(sheet_name).Select Range("B4").Select Selection.End(xlToRight).Select codeend = Selection.Column() Range("A5").Select Selection.End(xlDown).Select dayend = Selection.Row() For i = 2 To codeend If code = Cells(4, i).Value Then Range(Cells(dayend, i), Cells(5, i)).Select Selection.Copy Sheets("商品名").Select Range("K3").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End If Next Next Next End Sub というマクロをつくってみたのですが、何順目かあたりから For r = 2 To 3 のｒがなぜか4になっています。正直知識がないのでさっぱりわかりません。どこに問題があるか詳しい方教えてください。
- ベストアンサー
- オフィス系ソフト
- セルの選択について
<Sheet2のコード> Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not UserForm3.Visible Then UserForm3.Show 0 UserForm3.TextBox1.Text = Selection.Count End Sub *********************************************** <UserForm3のコード> Private Sub CommandButton1_Click() With Selection .MergeCells = True .WrapText = True .Value = TextBox2.Text & ComboBox1.Text End With UserForm3.Hide End Sub ---------------------------------------------- Private Sub UserForm_Initialize() Dim lastrw As Integer, lastrw2 As Integer, i As Integer lastrw = Sheet3.Range("A1").End(xlDown).Row lastrw2 = Sheet3.Range("B1").End(xlDown).Row If Sheet2.Range(Cells(5, 4), Cells(5, 100)).Select Then ・・・(1) For i = 1 To lastrw - 1 ComboBox1.AddItem Sheet3.Cells(i + 1, 1).Value Next i End If If Sheet2.Range(Cells(6, 4), Cells(6, 100)).Select Then ・・・(2) For i = 1 To lastrw2 - 1 ComboBox1.AddItem Sheet3.Cells(i + 1, 2).Value Next i End If End Sub ************************************************* ワークシート上でマウスで選択されたセルの行ごとにUserForm3のComboBox1で表示させる文字を変えたいのですが、どのようにすればよいのでしょうか。 上の(1)(2)だととマウスで選択されたセルではなく(1)(2)の範囲のセルが結合されてしまいます。。。 また、今はワークシート上でマウスを左クリックする度にUserForm3が表示されてしまいます。 これをワークシート上でマウスでセルを選択して右クリックするとUserForm3が表示される ようにしたりすることは可能なのでしょうか。
- ベストアンサー
- Visual Basic
- Excel VBA でテキストボックスの値をセルA列から検索
いつもお世話になります。 Private Sub CommandButton3_Click() Dim 行 As String Dim 列 As String Dim 最終行 As String Dim 検索行 As String Dim メッセージ As Integer Dim 一致 As Range Dim myNO As Variant Dim i As Long Sheets(3).Select 最終行 = Range("A2").End(xlDown).Offset(1).Select 行 = ActiveCell.Row 列 = ActiveCell.Column myNO = TextBox2.Value 検索行 = Range("A2").End(xlDown).Select ※・・・Set 一致 = Range("A2:検索検").Findwhat:=TextBox2,lookat:=xlWhole) If 一致 Is Nothing Then MsgBox "データがありません。新規コード入力します。" Cells(行, 列 + 0) = UserForm1.TextBox2.Value Cells(行, 列 + 1) = UserForm1.ComboBox7.Value Else i = Cells(行 - 1, "A") Cells(i, 列 + 0) = UserForm1.TextBox2.Value Cells(i, 列 + 1) = UserForm1.ComboBox7.Value End If End Sub 「エラー1004'Range'メソッドは失敗しました'Global'オブジェクト」とでます。※印が黄色になっています。 ユーザーフォーム1のテキストボックスの値をシート3のA列から検索して、一致すれば、A列の一致セルに上書き入力して、一致が無い場合はA列の空白セルに追加入力したいのです。よろしくお願い致します。
- ベストアンサー
- その他（プログラミング・開発）
- Select Case について
Sub dummy() Dim Dummy As Worksheet Dim SheetName As String Dim i As Integer Dim GEN As Long Dim OTA As Long With Sheets("入力") '3行目～22行目まで For i = 3 To 22 SheetName = Sheets("入力").Range("D3").Value On Error Resume Next Set Dummy = Sheets(SheetName) 'もしシートがあれば・・・ If Err.Number = 0 Then Select Case .Cells(i, 14).Value Case "TK-001" OTA = Sheets("TK-001").Range("B65536").End(xlUp).Row + 1 Sheets("TK-001").Range("B" & OTA).Value = .Cells(i, "H").Value Sheets("TK-001").Range("I" & OTA).Value = .Cells(i, "I").Value Sheets("TK-001").Range("F" & OTA).Value = .Cells(i, "K").Value Sheets("TK-001").Range("G" & OTA).Value = .Cells(i, "L").Value Sheets("TK-001").Range("J" & OTA).Value = .Cells(i, "M").Value End Select 'シートが無ければ・・・ Else '原紙をコピーする Sheets("原紙").Copy BEFORE:=Sheets(1) 'シートの名前を市場コードにする Sheets(1).Name = SheetName End If Next End With On Error GoTo 0 End Sub 上記の通りマクロを組みましたが、以下の事を行うのに悩んでいます。 (1)Select Case が100通りあるのですが、全てCaseを入れるのではなく もっと簡単な方法はありますか？ ※『リスト』シートを作っており、B1～B100までcaseになるコードが入力されています。 例： B 1 TK-001 2 TK-002 3 TK-003 ・ ・ ・ 100 TK-100 というシートを作っています。 (2)今のマクロではどんな値でもシートがなければシートを作ってしまう状態ですが、 もし『リスト』シートの中に値があればシートを作る、無ければ作らないというマクロは可能ですか
- ベストアンサー
- その他（プログラミング・開発）
- loop終了後のセルの一個右から同様のloopを行う方法
・loop終了後のセルの一個右から同様のloopのプログラムを組むのが目的です。 ・データはA列にランダムに数字が入っているものとします。 ・条件式としては基準値より小さな数字が一個下のセルにあったら↓を表示して、さらに下に行くという風にして、基準よりも多くなったところでloopがストップする設定です。 ・困っているところをうまく表現できてないかも知れませんが、よろしくお願いします。 --------------------------- Sub 比較() Dim i As Integer Dim j As Integer Cells(1, 2).Select ActiveCell.FormulaR1C1 = "=IF(RC1>R1C1,""→"",""↓"")" i = 1 Do While Cells(i, 2).Value <> "" If Cells(i, 2).Value = "↓" Then Cells(1 + i, 2).Select ActiveCell.FormulaR1C1 = "=IF(RC1>R1C1,""→"",""↓"")" End If i = i + 1 Loop Cells(i - 1, 3).Select ActiveCell.FormulaR1C1 = "=IF(RC1>R" & i - 1 & "C1,""→"",""↓"")" j = 1 Do While Cells(i - 2 + j, 3).Value <> "" If Cells(i - 2 + j, 3).Value = "↓" Then Cells(i - 1 + j, 3).Select ActiveCell.FormulaR1C1 = "=IF(RC1>R" & i - 1 & "C1,""→"",""↓"")" End If j = j + 1 Loop End Sub
- ベストアンサー
- Visual Basic
お礼
ご回答ありがとうございます。私もそう思いましたが、こういうコードはSub()の後・End Subの前に書くことが前提でした。問題は解決しました。親切にありがとうございます。