砂時計のクリックしないと矢印に戻らない問題の解決方法| OKWAVE

処理を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

やはり図形のクリアで実行時エラー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

マクロの処理速度が遅くなってしまいました

　今までエクセル２０００を使用していたのですが、エクセル２００３にバージョンアップして、以下の処理速度を検証したところ、処理が遅くなってしまいました。内容は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秒位かかってしまいます。処理速度が遅くなってしまうとバージョンアップした意味がないのですが、原因や改善策があればどなたか教えていただけないでしょうか？よろしくお願いします。

マクロが実行しない

　二行三列を一枡として月の勤務割表を作成しています。マクロで同じ事をしているのに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

印刷プレビュー表示後ユーザーフォームが閉じません。

　下記のコードで印刷プレビューが表示された後,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

ＶＢＡ超初心者です

皆さんのお知恵を拝借させてください。 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が表示されるようにしたりすることは可能なのでしょうか。

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

表計算

Sub TaskManager() Dim i As Integer Dim Maxval As Integer Dim Counter As Integer Dim AtoShoriFlg As String Set SH1 = Worksheets("Sheet1") Set SH2 = Worksheets("Sheet2") Maxval = WorksheetFunction.Max(Range("B:B")) Maxval = Maxval + 1 '初期値設定 i = 7 AtoShoriFlg = "ON" Counter = 1 Do While Cells(i, 4).Value <> "end" Select Case Cells(i, 4) Case Is = "新規エントリー" AtoShoriFlg = "OFF" i = i + 1 Case Is = "" Cells(i - 1, 4).Copy Cells(i, 4) Cells(i, 4).Font.Color = RGB(255, 255, 255) SH1.Range(SH1.Cells(i, 2), SH1.Cells(i, 6)).Borders(xlEdgeTop).LineStyle = xlLineStyleNone Case Is <> Cells(i - 1, 4) SH1.Range(SH1.Cells(i, 2), SH1.Cells(i, 6)).Borders(xlEdgeTop).LineStyle = xlContinuous SH1.Range(SH1.Cells(i, 2), SH1.Cells(i, 6)).Font.Color = RGB(0, 0, 0) If Cells(i, 2) = "" Then Cells(i, 2) = Maxval Maxval = Maxval + 1 End If Counter = 1 Case Else SH1.Range(SH1.Cells(i, 2), SH1.Cells(i, 6)).Borders(xlEdgeTop).LineStyle = xlLineStyleNone End Select If Cells(i, 2).Value = "" Then Cells(i, 2) = Cells(i - 1, 2).Value Cells(i, 2).Font.Color = RGB(255, 255, 255) End If If Cells(i, 3).Value = "" And Counter <> 1 Then Cells(i, 3) = Cells(i - 1, 3).Value Cells(i, 3).Font.Color = RGB(255, 255, 255) End If If AtoShoriFlg = "ON" Then Cells(i, 7) = Counter Counter = Counter + 1 End If i = i + 1 Loop SH1.Range(SH1.Cells(i, 2), SH1.Cells(i, 6)).Borders(xlEdgeTop).LineStyle = xlContinuous If AtoShoriFlg = "ON" Then SH2.Range("B2:F5").Copy Destination:=SH1.Cells(i, 2) End If End Sub

VBAで最終行の取得について

UserFormのConboBoxで「○○」を選んで、 UserFormのTextBoxで『あいう』と入力すると、ワークシートに A 　　　　　B 1 ○○　　 ×× 2 あいうと表示され、 UserFormのConboBoxで「××」を選んで、 UserFormのTextBoxで『アイウ』と入力すると A 　　　　　B 1 ○○　　 ×× 2 あいう　アイウ 3 : 　　　: と表示されるようにしたいと思います。以下のプログラムまではできています。 ********************************************* Private Sub UserForm_Initialize() 　Dim lasClm As Integer, i As Integer 　lasClm = Sheet1.Range("A1").End(xlToRight).Column 　　For i = 1 To lasClm 　　ComboBox1.AddItem Sheet1.Cells(1, i).Value 　　Next i End Sub ********************************************* Private Sub CommandButton1_Click() 　Select Case ComboBox1.Text 　Case Sheet1.Cells(1, 1).Value　'「○○」が選択　Sheet1.Cells(2, 1).Value = TextBox1.Text　・・・(1) 　Case Sheet1.Cells(1, 2).Value　'「××」が選択　Sheet1.Cells(2, 2).Value = TextBox1.Text　・・・(2) 　End Select 　UserForm1.Hide End Sub ********************************************** 今は(1)、(2)のように直接セルを指定しているのですが、この部分を各列（A列、B列）の最終行の値を取得して、最終行＋１のセルに順次TextBoxに入力された値を代入していきたいのですが、どのようにしたらよいのでしょうか。しかし、A列とB列は同じように値が増えていくとは限りません。例）　　　A 　　　 B 1 ○○　　　×× 2 あいう　アイウ 3 かきく 4　さしすとなる場合もあるので、A列とB列それぞれの最終行の値を取得したいと思っています。

VBAのコードに関する質問です。

以下のコードで実行しているのですが上手くデータ数のカウンタが上手くいきません。助言をお願いしたいです。 Range("D2").Select ActiveCell.Formula = "=0.001*C2+D1" Range("D2").Select Selection.AutoFill Destination:=Range("D2:D" & fin), Type:=xlFillDefault Range("D2:D" & fin).Select Dim i As Long, j As Long, flg As Boolean Dim i1 As Long j = 1 For i = 2 To Cells(Rows.count, 2).End(xlUp).Row If Cells(i, 2) = 2 Then flg = True ElseIf Cells(i, 2) = 3 And flg = True Then i1 = i Cells(1, 7) = i - 1 Cells(j, 5) = Cells(i, 4) Cells(j, 6) = Cells(i - 1, 4) flg = False Exit For Else: flg = False End If Next For i = i To Cells(Rows.count, 2).End(xlUp).Row If Cells(i, 2) = 2 Then flg = True ElseIf Cells(i, 2) = 3 And flg = True Then j = j + 1 Cells(j, 7) = i - i1 - 2 i1 = i Cells(j, 5) = Cells(i, 4) Cells(j, 6) = Cells(i - 1, 4) flg = False Else: flg = False End If Next Range("E1").Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Cells(1, 5) = Cells(2, 4) Cells(Rows.count, 6).End(xlUp).Offset(1).Value = _ Cells(Rows.count, 4).End(xlUp).Value Cells(Rows.count, 7).End(xlUp).Offset(1).Value = 200 Range("H1").Select ActiveCell.Formula = "=(F1-E1)/G1" Range("H1").Select Selection.AutoFill Destination:=Range("H1:H16"), Type:=xlFillDefault Range("H1:H16").Select Range("E1").Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Range("F1").Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Range("G1").Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Range("H1").Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Dim rowStr As Long, rowEnd As Long Dim A, D, Da, H, K '演算：K=D-Da-H*A Dim cntS As Integer, cntA As Integer Dim cntD As Integer, cntH As Integer Dim r As Long, t As Long rowStr = 2 '開始行 rowEnd = Cells(Rows.count, 7).End(xlUp).Row 'G列で最終行を求める cntS = 1 '周期初期値 cntD = rowStr 'D列行数初期値 cntH = rowStr 'H列行数初期値 For r = rowStr To rowEnd cntA = rowStr For t = 1 To Cells(r, 7) '各周期の繰り返し処理 A = Cells(cntA, 1).Value D = Cells(cntD, 4).Value If t = 1 Then If r = rowStr Then Da = 0 '1周期目は0とする Else '2週期目以降は最初の値に固定 Da = Cells(cntD, 4).Value End If '周期の区切りをF列に出力 Cells(cntD, 11).Value = cntS & "周期" End If H = Cells(cntH, 8).Value K = D - Da - H * A '演算 Cells(cntD, 10).Value = K cntA = cntA + 1 'A列カウンタ更新 cntD = cntD + 1 'D列カウンタ更新 Next t cntS = cntS + 1 '周期カウンタ更新 cntH = cntH + 1 'H列カウンタ更新 Next r

マクロエラー処理

下記のマクロを実行すると、If (.Range　のところでコンパイルエラー参照が不正または不完全です。というメッセージが出るのですが、どこを修正すればよいのでしょうか教えてください。 Sub 再表示1() Dim SheetName As String Dim i As Integer Dim LastRow As Integer Dim rng As Range LastRow = 3000 '最終行の番号 Sheets("ＡＣＴ").Select For i = 6 To LastRow If (.Range("D" & i) = "A310" Or .Range("D" & i) = "A505") And .Range("V" & i) < 0 Then .Cells(i, "W").Resize(1, 3).ClearContents End If Next Stop End With End Sub

Worksheet_Changeについて

　特定のマクロの前後でWorkSheet_Changeを終了し再開させる方法がありましたらお願い致します。 Windows7 SP1 Office2010 Private Sub WorkSheet_Change(ByVal Target As Range) Dim c As Range For Each c In Target Select Case c.address(0, 0) Case "C1" If Intersect(Target, Range("C1")) Is Nothing Then Exit Sub '検査範囲 Application.EnableEvents = False '再帰実行の停止 If Range("C1").Value <> Sheets("祝祭日").Range("A1").Value Then MsgBox ("祝日の設定を反映するため年度を同じにしてください。") End If Application.EnableEvents = True Case Else Select Case c.address(0, 0) Case "G1" If Range("G1") = 4 Then '4月データの表示 Dim ret As Integer ret = MsgBox(Format(ActiveSheet.Range("G5").Value, "ge年mm月") & "の勤務割表の編集＆入力保存データを元に表示します。" & vbCrLf & "よろしいですか?", _ vbOKCancel + vbQuestion, "勤務割表表示切替確認") Select Case ret Case vbOK UserForm8.Show vbModeless UserForm8.Repaint 当月データのクリアメインデータの復元4月編集データの復元4月 Sheets("メイン・1").Select Unload UserForm8 Sheets("メイン・1").Range("G1").Select ActiveCell.FormulaR1C1 = "4" ※ ここで終了ないし一時停止図形の貼付け ※ここで再開させたいのですが? Case vbOKCancel Exit Sub End Select ElseIf Range("G1") = 5 Then '5月データの表示 ret = MsgBox(Format(ActiveSheet.Range("G5").Value, "ge年mm月") & "の勤務割表の編集＆入力保存データを元に表示します。" & vbCrLf & "よろしいですか?", _ vbOKCancel + vbQuestion, "勤務割表表示切替確認") Select Case ret Case vbOK UserForm8.Show vbModeless UserForm8.Repaint 当月データのクリアメインデータの復元5月編集データの復元5月 Sheets("メイン・1").Select Unload UserForm8 図形の貼付け Case vbOKCancel Exit Sub End Select End If End Select End Select Next End Sub

Excel関数とVBAの組み合わせで。

名前　　｜　　総合計　　｜　　ランキングあああ　｜　　10　　　　｜　　　3 いいい　｜　　12　　　　｜　　　2 ううう　　｜　　8　　　　　｜　　4 えええ　｜　　　20　　　　｜　　1 おおお　｜　　4　　　　　｜　　　5 というような感じでシートに入力されています。（ランキングの部分はRANK関数を使用）これを元にグラフを作成するために、1位から3位までを変動的に抽出するようなコードを下記のようにしました。 -------------------------------------------------- Sub IP_Graph() Dim i As Integer Dim Ranking As String Dim Provider As String Dim AccessCount As String Dim Last As Integer '最終行取得 Last = Cells(2).CurrentRegion.Rows.Count For i = 3 To Last Ranking = Cells(i, 10) Provider = Cells(i, 2) AccessCount = Cells(i, 9) Select Case Ranking Case 1 Range("p_01") = Cells(i, 1) Range("access_01") = Cells(i, 2) Case 2 Range("p_02") = Cells(i, 1) Range("access_02") = Cells(i, 2) Case 3 Range("p_03") = Cells(i, 1) Range("access_03") = Cells(i, 2) End Select Next End Sub -------------------------------------------------- 上のように、1位から5位まで、ときちおんとランク分けされていればいいのですが、実際は同じ数でランキングが同位だったりすることがおこります。（例えば1位・2位・2位・4位・5位のように。）このような場合抜き出して作成した表の3位の部分が空欄になってしまいます。上位3つを抜き出すためにはどうしたらいいのでしょうか？表示上の並べ替えは行いたくないです。 Ex:2000

VBAでの質問

お世話になります。下記の記述で、「←」の矢印の記述で、 Cells.（５，２）がブランクでなければ、「→」から進めたいのですが、どの様に記述すれば宜しいでしょうかご教示お願いします。 Sub 表記入() Dim Data As Range Dim i As Integer Dim j As Integer Dim k As Integer Set Data = Sheets("集計").Range("A2").CurrentRegion j = 16 k = 0 With Sheets("表") For i = 3 To Data.Rows.Count If Data.Cells(i, 51) <> "" Then .Cells(5, 2) = Data.Cells(i, 3)　　← .Cells(5, 7) = Data.Cells(i, 4) → .Cells(j, 2) = Data.Cells(i, 10) .Cells(j, 6) = Data.Cells(i, 11) & Data.Cells(i, 12) .Cells(j, 14) = Data.Cells(i, 51) Else End If k = k + 1 If k = 10 Then j = j + 18 k = 0 Else j = j + 1 End If End If Next i End With End Sub

EXCEL VBA

EXCEL VBAで空白行が現れたら「小計」の文字を入力したいと思い以下のように記述しましたが、うまくいきません。どこがおかしいのか教えてください。宜しくお願いします。 Sub write小計() Dim i As Integer Dim rowcnt As Integer rowcnt = Cells(1, 1).CurrentRegion.Rows.Count Range("B1").Select For i = 1 To rowcnt If Cells(i, 2).Value = "" Then Value = "小　計" ActiveCell.Offset(1).Select Next i End Sub

エクセルVBAの繰り返し処理の質問

Ｃ列にある項目とＧ列にある項目を比較して、一致し、Ｈ列にある数字が10以上ならば、Ｂ列にフラグ１を立てるという処理を行いたいんですが、下記ぐらいまでしか作れず、うまくいきません・・・ Sub フラグを立てる処理() Dim i As Integer Dim j As Integer Dim k As Integer i = 1 j = 1 Do j = j + 1 Do i = i + 1 If Cells(j, 8) > 9 Then Cells(i - 1, 4) = 1 End If Loop Until Cells(i, 3) <> Cells(j, 7) Or Cells(i, 3) = "" Loop Until Cells(j, 7) = "" End Sub わかる方がいらっしゃいましたら、お願いします。

データ検索ネスト　Excel VBA

excel2003でデータ検索の処理をするというマクロをVBAで作成したいのですが、うまく動作しません。自作のVBAを記載してみましたので何が原因なのか教えてください。初心者です、よろしくお願いします。 Sub データ検索() Dim i As Integer, j As Integer, k As Integer, l As Integer Dim myRange As Range Dim IngLastrow As Long IngLastrow = Range("A65536").End(xlUp).Row For i = 3 To IngLastrow For j = 3 To 25 For k = 8 To 53 For l = 3 To 9 Set myRange = Worksheets("データベース").Cells(i, "o").Find(what:=Worksheets("コード").Cells(j, "o").Value, _ LookIn:=xlValues) If Not myRange Is Nothing Then Worksheets("予定").Cells(k, l).Value = myRange.Offset(, -12).Value End If Next l Next k Next j Next i End Sub

砂時計のクリックしないと矢印に戻らない問題の解決方法

処理終了後のに砂時計が、クリックしないと矢印に

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

お礼 2012/10/22 00:21

関連するQ&A

処理を1行飛ばして実行

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

マクロの処理速度が遅くなってしまいました

マクロが実行しない

印刷プレビュー表示後ユーザーフォームが閉じません。

ＶＢＡ超初心者です

セルの選択について

Excel VBA でテキストボックスの値をセルA列から検索

Select Case について

loop終了後のセルの一個右から同様のloopを行う方法

表計算

VBAで最終行の取得について

VBAのコードに関する質問です。

マクロエラー処理

Worksheet_Changeについて

Excel関数とVBAの組み合わせで。

VBAでの質問

EXCEL VBA

エクセルVBAの繰り返し処理の質問

データ検索ネスト　Excel VBA

注目のQ&A

カテゴリ

あなたにピッタリな商品が見つかる！ OKWAVE セレクト

専門家に質問してみよう

砂時計のクリックしないと矢印に戻らない問題の解決方法

処理終了後のに砂時計が、クリックしないと矢印に

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

お礼 2012/10/22 00:21

関連するQ&A

処理を1行飛ばして実行

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

マクロの処理速度が遅くなってしまいました

マクロが実行しない

印刷プレビュー表示後ユーザーフォームが閉じません。

ＶＢＡ超初心者です

セルの選択について

Excel VBA でテキストボックスの値をセルA列から検索

Select Case について

loop終了後のセルの一個右から同様のloopを行う方法

表計算

VBAで最終行の取得について

VBAのコードに関する質問です。

マクロエラー処理

Worksheet_Changeについて

Excel関数とVBAの組み合わせで。

VBAでの質問

EXCEL VBA

エクセルVBAの繰り返し処理の質問

データ検索ネスト Excel VBA

注目のQ&A

カテゴリ

あなたにピッタリな商品が見つかる！ OKWAVE セレクト

専門家に質問してみよう

データ検索ネスト　Excel VBA