- ベストアンサー
このコードに3行を追記しましたら、動作がだいぶ遅くなってしまった！
Windows XP Home Edition Service Pack 3 Office XP Personal 2002 Excel 2002 下記コードについて２点お伺いさせて下さいませ。 （１）●の3行を追記しましたら、動作がだいぶ遅くなりましたが、仕方ありませんでしょうか？ 記述する順序がいけませんでしょうか？ （２）●■が実行されません。 よろしくご教示お願い致します。 Sub TEST() Dim r As Range On Error Resume Next With Worksheets(Worksheets.Count) For Each r In .Range(Range("A2").End(xlDown).Offset(3, 2), .Range("A65536").End(xlUp).Offset(0, 25)) If r.Cells.Value >= 2 And r.Cells.Value <> 0 And r.Cells.Value <> "" Then With r.Offset(-38, 0) .Font.ColorIndex = 10 '緑色にする .Interior.ColorIndex = 36 '黄色にする .Borders.LineStyle = xlContinuous '● .Borders.Weight = xlMedium '●太線 .ColorIndex = 5 '●■紺色 '←ここが動作しません End With End If Next r End With
- oshietecho-dai
- お礼率79% (263/330)
- オフィス系ソフト
- 回答数4
- ありがとう数4
- みんなの回答 （4）
- 専門家の回答
質問者が選んだベストアンサー
このあたりを参考にして、For文の前で画面更新をFALSEにして、End Withの後で画面更新をTrueにしてみては。 http://www.relief.jp/itnote/archives/001259.php
その他の回答 (3)
- watabe007
- ベストアンサー率62% (476/760)
>For Each r In .Range(Range("A2").End(xlDown).Offset(3, 2 .Range(.Range("A2") ↑ .(カンマが抜けている) >.ColorIndex = 5 '●■紺色 '←ここが動作しません 罫線の色なら .Borders.ColorIndex = 5 With Worksheets(Worksheets.Count) For Each r In .Range(.Range("A2").End(xlDown).Offset(3, 2), .Range("A65536").End(xlUp).Offset(0, 25)) If r.Cells.Value >= 2 And r.Cells.Value <> 0 And r.Cells.Value <> "" Then With r.Offset(-38, 0) .Font.ColorIndex = 10 .Interior.ColorIndex = 36 .Borders.LineStyle = xlContinuous .Borders.Weight = xlMedium .Borders.ColorIndex = 5 End With End If Next r End With
お礼
早速のご回答誠に有難うございました。 抜けてました！ これで、完璧になりました。 皆様が良回答でございました。
- Saturn5
- ベストアンサー率45% (2270/4952)
Borders..ColorIndex = 5 ではないでしょうか？ 遅くなっているのはループ回数が固定で多いからだと思います。 実際に使用されているセルはもっと少ないのではないでしょうか？ ループ回数は動的にデータ数に合わせた方が速いです。 また、全体的には条件書式で処理できるようにも思えます。
お礼
早速のご回答誠に有難うございました。 おっしゃられ通りです。 今後、工夫してみます。
- nagare
- ベストアンサー率33% (280/831)
2の方ですが、記述が違いますよ .Interior.ColorIndex = 5 .Borders.LineStyle(罫線の場所) = xlContinuous http://officetanaka.net/excel/vba/cell/cell07.htm ※どれくらい遅くなっているのでしょうか?
お礼
早速のご回答誠に有難うございました。 ずばりのページがあったんですね。 .Borders.ColorIndex = 5 でございました。
補足
＞※どれくらい遅くなっているのでしょうか? 1.6倍ぐらいだと思います。 No.1様の方法で、少し速くなりました。 有難うございました。
関連するQ&A
- このコードですが、うまく実行できません！
EXEL 2002 です。 最終シートに 「約40行」 ぐらいのデータがあり、 その各行の列に、 約20個の数値のセルがあり、 その各セルの数値が 3 以上だったら、 「.Offset(38, 0)」セルを赤色にする。 を、全部の 「約40行」 に実行したいと思っております。 下記コードなのですが、 うまくできません、 3行目がエラーとなります。 何卒、ご教示よろしくお願い致します。 ------------------------- Sub 数値3以上なら上方セルを赤色にする() Dim r As Range With Worksheets(Worksheets.Count) For Each r In .Range("A40", .Range("A65536").End(xlUp)) If r.Offset(0, 1).Resize(, r.Offset(0, 1).Range("IV40").End(xlToLeft)).Cells.Value >= 3 Then r.Offset(38, 0).FormatConditions(1).Interior.ColorIndex = 3 '赤に塗りつぶす End If Next r End With End Sub
- ベストアンサー
- オフィス系ソフト
- エクセル：シートを切り替えずに別シート上の操作をする
タイトルが正しいかどうか疑問ですが。 シート[Sheet1]にて値を入力したアドレス(の行番号と列番号)を取得し、 その周囲のセルの罫線の色を赤(3)から灰色(15)に置換するコードを作っています。 Sheet1のコードには、 Private Sub Worksheet_Change(ByVal Target As Range) AAA Target End Sub とだけ書き、入力があったらプロシージャAAAへTargetを持って飛びます。 Sub AAA(ByVal Target As Range) Dim M_Row As Integer Dim M_Clm As Integer Dim Y As Range M_Row = Target.Row M_Clm = Target.Column For Each Y In Worksheets("Sheet1").Range(Cells(M_Row - 2, M_Clm), Cells(M_Row + 1, M_Clm + 5)) With Y If .Borders(xlEdgeTop).ColorIndex = 3 Then .Borders(xlEdgeTop).ColorIndex = 15 If .Borders(xlEdgeLeft).ColorIndex = 3 Then .Borders(xlEdgeLeft).ColorIndex = 15 If .Borders(xlEdgeBottom).ColorIndex = 3 Then .Borders(xlEdgeBottom).ColorIndex = 15 End With Next End Sub ここまでは正常に動きます。 この後に、アクティブでないシート[Sheet2]の同じセル範囲にある罫線の色も同じように置換したいので、 上記コードに続けて、以下のように書きました。 Sub AAA(ByVal Target As Range) Dim M_Row As Integer Dim M_Clm As Integer Dim Y As Range M_Row = Target.Row M_Clm = Target.Column For Each Y In Worksheets("Sheet1").Range(Cells(M_Row - 2, M_Clm), Cells(M_Row + 1, M_Clm + 5)) With Y If .Borders(xlEdgeTop).ColorIndex = 3 Then .Borders(xlEdgeTop).ColorIndex = 15 If .Borders(xlEdgeLeft).ColorIndex = 3 Then .Borders(xlEdgeLeft).ColorIndex = 15 If .Borders(xlEdgeBottom).ColorIndex = 3 Then .Borders(xlEdgeBottom).ColorIndex = 15 End With Next For Each Y In Worksheets("Sheet2").Range(Cells(M_Row - 2, M_Clm), Cells(M_Row + 1, M_Clm + 5)) With Y If .Borders(xlEdgeTop).ColorIndex = 3 Then .Borders(xlEdgeTop).ColorIndex = 15 If .Borders(xlEdgeLeft).ColorIndex = 3 Then .Borders(xlEdgeLeft).ColorIndex = 15 If .Borders(xlEdgeBottom).ColorIndex = 3 Then .Borders(xlEdgeBottom).ColorIndex = 15 End With Next End Sub これだと、 For Each Y In Worksheets("Sheet2").Range(Cells(M_Row - 2, M_Clm), Cells(M_Row + 1, M_Clm + 5)) の部分で失敗します。 この１行前に、 Sheets("Sheet2").Select と入れてやると正常に動作するのですが、 シートを切り替えずにやりたいと思っています。 可能でしょうか？ 以下のように、 実行後にSheet1に戻し、 それらを Application.ScreenUpdating = False Application.ScreenUpdating = True で挟むことで、見た目はシートを切り替えずに実行できるのですが、 実際にこのコードを組み込んでいるシートはシート上にあるデータが多いためか(600行×100列程度）、 全く同じコードを実行しても一瞬画面がチラついてしまいます。 （新規Bookで同じコードを組み込んで、何行かに罫線を引いただけのシートだと全くチラつかなかったので、 シート上のデータが多いせいじゃないかと思いました） Sub AAA(ByVal Target As Range) Dim M_Row As Integer Dim M_Clm As Integer Dim Y As Range M_Row = Target.Row M_Clm = Target.Column For Each Y In Worksheets("Sheet1").Range(Cells(M_Row - 2, M_Clm), Cells(M_Row + 1, M_Clm + 5)) With Y If .Borders(xlEdgeTop).ColorIndex = 3 Then .Borders(xlEdgeTop).ColorIndex = 15 If .Borders(xlEdgeLeft).ColorIndex = 3 Then .Borders(xlEdgeLeft).ColorIndex = 15 If .Borders(xlEdgeBottom).ColorIndex = 3 Then .Borders(xlEdgeBottom).ColorIndex = 15 End With Next Application.ScreenUpdating = False Sheets("Sheet2").Select For Each Y In Worksheets("Sheet2").Range(Cells(M_Row - 2, M_Clm), Cells(M_Row + 1, M_Clm + 5)) With Y If .Borders(xlEdgeTop).ColorIndex = 3 Then .Borders(xlEdgeTop).ColorIndex = 15 If .Borders(xlEdgeLeft).ColorIndex = 3 Then .Borders(xlEdgeLeft).ColorIndex = 15 If .Borders(xlEdgeBottom).ColorIndex = 3 Then .Borders(xlEdgeBottom).ColorIndex = 15 End With Next Sheets("Sheet1").Select Application.ScreenUpdating = True End Sub よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- エクセル マクロ VBA 罫線 文字列
職場で使う表をVBAマクロを用いて罫線作成をしています。 前任者のアレンジを頼まれたのですが前任者に連絡が取れず困っています。 表の特徴は以下のようになります。 ・A列を飛ばし、B列から2列飛びで文字を記入 ・b2＝曜日、b3＝1、b4＝2、b5＝3、b6＝4、b7＝空白のセットが曜日ごとに2セット×7日分 この表を ・b2＝曜日、b3＝-3、b4＝-2、b5＝-1、b6＝0、b7＝1、b8＝2、b9＝3、b10＝4、b11＝空白のセットが曜日ごとに2セット×7日分 に変更したいのですが空欄の場所がずれてしまい上手くいきません。 原本のマクロは以下です。 ---------------------------------------------------------------- Sub 罫線作成() Range(Cells(4, 1), Cells(86, 22)).Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone Selection.Borders(xlEdgeLeft).LineStyle = xlNone Selection.Borders(xlEdgeTop).LineStyle = xlNone Selection.Borders(xlEdgeBottom).LineStyle = xlNone Selection.Borders(xlEdgeRight).LineStyle = xlNone Selection.Borders(xlInsideVertical).LineStyle = xlNone Selection.Borders(xlInsideHorizontal).LineStyle = xlNone ch1 = "月火水木金土日" For i = 4 To 76 Step 12 n1 = (i + 8) \ 12 Range(Cells(i, 1), Cells(i + 10, 22)).Select With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With With Selection.Borders(xlInsideVertical) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With 'Cells(i, 1) = Mid(ch1, n1, 1) For i2 = 2 To 20 Step 3 For i3 = i To i + 10 nb1 = (i3 + 8) Mod 12 If nb1 = 0 Or nb1 = 6 Then Cells(i3, i2) = Mid(ch1, n1, 1) If nb1 = 1 Or nb1 = 7 Then Cells(i3, i2) = 1 If nb1 = 2 Or nb1 = 8 Then Cells(i3, i2) = 2 If nb1 = 3 Or nb1 = 9 Then Cells(i3, i2) = 3 If nb1 = 4 Or nb1 = 10 Then Cells(i3, i2) = 4 Next Next Next End Sub ---------------------------------------------------------------- 4行目から142行目まで使用することは分かっているのですが… どうかご助力お願いします。
- ベストアンサー
- オフィス系ソフト
- 表に罫線を最終列まで引きたい
windows7 とExcel2007でマクロ作成中の初心者です。 最初に、D2:E34を選んで罫線をひき、列を２列移動して、また罫線を引きます。 これをデータのある最終列まで繰り返したいのですが、うまくいきません。 どうしたらよろしいでしょうか。 Sub 勤怠に罫線() Dim n As Integer For n = 1 To 5 勤怠に罫線 Selection.Offset(0, 2).Select 勤怠に罫線 Next n End Sub 以下はマクロの自動記録でコードを書きました。 Sub 勤怠に罫線() Range("D2:E34").Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = xlAutomatic .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = xlAutomatic .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = xlAutomatic .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = xlAutomatic .TintAndShade = 0 .Weight = xlMedium End With Selection.Borders(xlInsideVertical).LineStyle = xlNone Selection.Borders(xlInsideHorizontal).LineStyle = xlNone Range("D2:E34").Select End Sub
- ベストアンサー
- Visual Basic
- セル色を５秒間隔で変える
マクロ作成でセルに色を３色順次に変わるようにしたいのですが、 セル色の変更時間が早く、最後の色のみの表示になります。 コマンドボタンをクリックすると、アクティブセル（B3からF3）までのセル色が黄色・薄青・赤に5秒間隔で変色し、その後、下のセルに移動します。 再度、コマンドボタンをクリックすると、先ほどの上のセルの色が消え、アクティブセルに黄色・薄青・赤に5秒間隔で変更するVBAをお教えください。マクロで作成したVBを表示しておきます。 {timer}を使用するみたいですが、理解出来ませんので、宜しくお願いします。 罫線も引いてあります。 ActiveCell.Range("A1:E1").Select With Selection.Interior Timer = 4 .ColorIndex = 35 .Pattern = xlSolid End With Selection.Interior.ColorIndex = xlNone With Selection.Interior .ColorIndex = 7 .Pattern = xlSolid End With Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With Selection.Borders(xlInsideVertical).LineStyle = xlNone ActiveCell.Offset(1, 0).Range("A1:E1").Select End Sub
- ベストアンサー
- Visual Basic
- すべてのシートでマクロを実行したい
以下のプログラムでは、選択したシートのみマクロが動作しています。ネット検索で見よう見まねで作ったため何がまちがっているのかわかりません。ご教示いただけるとありがたいです。 ・月の予定表で利用者が休みの日に斜線を引くマクロ ・入力ミスを防ぐためシート保護をしている Sub すべてのシート() Dim s As Worksheet For Each s In Worksheets s.Select Call 斜線 Next End Sub Sub 斜線() ActiveSheet.Unprotect Password:="1234" For i = 1 To Range("E10").End(xlDown).Row Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlNone If Range("E10").Value = 0 Then Exit Sub If Cells(i, "E").Value = "日" And Range("BP9").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If If Cells(i, "E").Value = "月" And Range("BP10").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If If Cells(i, "E").Value = "火" And Range("BP11").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If If Cells(i, "E").Value = "水" And Range("BP12").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If If Cells(i, "E").Value = "木" And Range("BP13").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If If Cells(i, "E").Value = "金" And Range("BP14").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If If Cells(i, "E").Value = "土" And Range("BP15").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If If Cells(i, "AY").Value = "祝日" And Range("BP16").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If Next i ActiveSheet.Protect Password:="1234" End Sub
- ベストアンサー
- Excel（エクセル）
- コードへ追記したら、特定のシートしか実行できません！
Windows XP Home Edition Excel 2002 http://oshiete1.goo.ne.jp/qa4952620.html 以前に、ご教授頂いたコードに少し追記して、しばらく問題なく使用していましたが、 本日、同ブックの他のシートで実行しましたら、無反応で、セルに色が付きません（エラーではありません）。 何度も行ってみましたが同じ結果です。 但し、'★部分「Offset(-1, 0)」の2箇所を削除して実行するとセルに色が付き、問題なく実行できます。 ちなみに、実行できないシートは、1行全部にオートフィルタ（▼）がかかってしまいます。 私は、いつもEntireRowにてオートフィルタ（▼）をかけております。 しかし、10列ぐらいだけにオートフィルタ（▼）をかけて、実行しても結果は、無反応で、セルに色が付きません。 問題なく実行できるシートでは、EntireRowにてオートフィルタ（▼）をかけても、データのある列までしか オートフィルタ（▼）がかかりません。 このコードは、どんなシートでも実行できると思っていたのですが、 特定のシートでしか実行できないのでしょうか？ 原因がわかりません。 よろしくお願い致します。 ------------ 'SheetModule Option Explicit Sub Worksheet_Calculate() Static r As Range Dim f As Filter Dim i As Long On Error GoTo errHndler With ActiveSheet If .AutoFilterMode Then With .AutoFilter If r Is Nothing Then Set r = .Range.Rows(1) For Each f In .Filters i = i + 1 '★ r.Cells(i).Offset(-1, 0).Interior.ColorIndex = IIf(f.On, 33, xlNone) '33()が、識別用 ColorIndex。任意で。 Next f End With Else '★ If Not r Is Nothing Then r.Offset(-1, 0).Interior.ColorIndex = xlNone Set r = Nothing End If End With errHndler: If Err.Number <> 0 Then MsgBox Err.Number & ":" & Err.Description End Sub
- ベストアンサー
- オフィス系ソフト
- インデックスが有効範囲に出ないと出る
下記のようなVBAを書きました。しかしインデックスが有効範囲にないとメッセージがでるのですが、どこがまちがっているでしょうか？？ Sub macro1() Dim i As Long Dim r As Long Worksheets("フェアリスト ").Select Worksheets("csv").Range("A:C").ClearContents For i = 2 To 50 Step 5 If Worksheets("フェアリスト").Cells(11, i + 1) <> "" Then r = Worksheets("フェアリスト").Cells(65536, i + 1).End(xlUp).Row Worksheets("フェアリスト").Range(Cells(11, i), Cells(r, i + 3)).Copy _ Destination:=Worksheets("csv").Range("B65536").End(xlUp).Offset(1) Worksheets("csv").Range("A65536").End(xlUp).Offset(1).Resize(r - 3, 1).Value = Worksheets("フェアリスト").Cells(8, i).Value End If Next i Worksheets("csv").Range("A1:C1").Delete shift:=xlShiftUp End Sub
- ベストアンサー
- オフィス系ソフト
- 空白セルと０値を識別させたい。（VBA）
すみません、誰か教えていただけますか。 シートの53、54、55行目にそれぞれ値入っています。 それを３行目にビジュアル的に表現させています。 55行目はセルの色で、53行目は数値があり同じ値が 続く部分の合計を出しています。 しかし、下記の記述ですと数値が0（変数D=0）の時に うまくいきません。空白セルと認識されてしまうと思います。 何か、良い方法があれば教えて頂けませんでしょうか。 宜しくお願いします。 Sub 表示() Dim a As Long Dim c As Long Dim D As Long Dim e As String Dim f As String c = 3 For a = 3 To 64 With Worksheets("Sheet1") If .Cells(53, a) <> .Cells(53, a + 1) Then .Range(.Cells(53, c), .Cells(53, a)).Select D = WorksheetFunction.Sum(Selection) e = D f = Selection(1).Offset(1, 0).Value G = Selection(1).Offset(2, 0).Value If D <> 0 Then Selection(1).Offset(-50, 0).Value = f + "//" + e .Range(.Cells(53, c), .Cells(53, a)).Offset(-50, 0).Select Selection.Interior.ColorIndex = G End If If Selection(1).Value = "" Then .Range(.Cells(53, c), .Cells(53, a)).Offset(-50, 0).Select Selection.ClearContents Selection.Interior.ColorIndex = xlNone End If c = a + 1 End If End With Next End Sub
- ベストアンサー
- オフィス系ソフト
- vb6.0でEXCELオブジェクトの使用
以下のプログラムで四苦八苦しております。 vb6.0だとエラーが出て、vbaだとエラーはなく正常に終了します。 （エクセルは2002です） ※vbは、「microsoft excel 10.0 object library」にチェックを 入れています。 vb6.0だと「w_range.Select」の下の行の 「With Selection.Borders(xlEdgeLeft)」で 「実行時エラー424 オブジェクトが必要です。」となります。 後、「microsoft excel 10.0 object library」にチェックを入れる 事によって、vbaで作成できるプロバティ・メッソド等は使用できる と考えていいのでしょうか？ ＊＊＊＊＊＊＊＊＊＊＊＊＊＊ Private Sub Form_Load() Dim xls_csv As Object Dim w_range As Object Set xls_csv = CreateObject("Excel.Sheet") Set xls_kei = CreateObject("Excel.Sheet") xls_csv.Sheets(1).Name = "test" xls_csv.Application.Visible = True With xls_csv.Worksheets(1) .Cells(1, 2).Value = "aaa" .Cells(1, 3).Value = "bbb" .Cells(1, 4).Value = "ccc" End With With xls_csv.Worksheets(1) Set w_range = .Range(.Cells(1, 2), .Cells(10, 4)) End With w_range.Select With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With End Sub ＊＊＊＊＊＊＊＊＊＊＊＊＊＊
- 締切済み
- Visual Basic
お礼
早速のご回答誠に有難うございます。 まだ、時間がかかるかも知れませんが、なんとなくわかってきました。 でも 「アクティブセルのある行列を目立たせる」 これ、・・・ ですね！ 行けます。