- ベストアンサー
エクセルのマクロについて教えて下さい。
エクセル2000を使用している初心者です。 マクロは昨日ここで、ご指導いただいたばかりです。 過去ログを参考にあるホームページから 赤いフォントを数えるマクロを、カレンダーの 年間休日数を数えるためにコピーしました。 1日かかって、動作する様にはなったのですが 私が範囲指定している場所の個数より多く、また シート全体の赤いフォントの個数よりも多い様なので す。以下にコピーしますのでどこがおかしいのか ご指導願えないでしょうか。 Sub 休日検索() Dim myRng As Range Dim myFlag As Byte Dim myBoldCnt As Long, myRedCnt As Long Dim myBoldOrRedCnt As Long, myBoldAndRedCnt As Long For Each myRng In Range("検索範囲")※私の書き換えたのはここだけ myFlag = 0 With myRng If .Font.Color = RGB(255, 0, 0) Then myFlag = myFlag + 1 If .Font.Bold Then myFlag = myFlag + 2 End With If myFlag And 1 Then myRedCnt = myRedCnt + 1 If myFlag And 2 Then myBoldCnt = myBoldCnt + 1 If myFlag And 3 Then myBoldOrRedCnt = myBoldOrRedCnt + 1 If myFlag = 3 Then myBoldAndRedCnt = myBoldAndRedCnt + 1 Next MsgBox "太字" & vbtab & vbtab & myBoldCnt & vbcrlf _ & "赤" & vbtab & vbtab & myRedCnt & vbcrlf _ & "太字または赤" & vbtab & myBoldOrRedCnt & vbcrlf _ & "太字かつ赤" & vbtab & myBoldAndRedCnt End Sub
- みんなの回答 (3)
- 専門家の回答
関連するQ&A
- エクセルVBAの実行スピードが落ちます
エクセルで検索を行うVBAを使用していますが、エクセル立ち上げ時はサクサク動きますが、検索を繰り返し使っていくと、実行速度が落ちてしまいます。 エクセルを再起動すれば、元どおりの速さに戻ります。 何が原因でしょうか?どうすれば防ぐことはできるでしょうか? よろしくお願い申し上げます。 実行環境 WindowsXPproSP3 Pen4 3.0Ghz メモリ1GB HDD80GB Office2003 VBAの検索部分 Function Kensaku3(Key1 As String, Range1 As String) As Long '縦方向の検索 Dim myRng As Range Dim Job1 As String Dim Col1 As Long Dim Row1 As Long Col1 = Range(Range1).Column Row1 = Range(Range1).row Cells(Row1, Col1).Select Set myRng = Range(Range1).Find(what:=Key1, _ After:=ActiveCell, LookIn:=xlValues, _ LookAt:=xlPart, SearchOrder:=xlByRows, _ SearchDirection:=xlNext, MatchCase:=False) If myRng Is Nothing Then Kensaku3 = 0 Else Kensaku3 = myRng.row End If Set myRng = Nothing End Function
- ベストアンサー
- オフィス系ソフト
- マクロでのエラーについて
エクセル2010 マクロエラーについて 以前 印刷について下記コードを提示して頂きました。 このコードが通る時と2回目の .Zoom = j で止まる時があります。 どなたか検証して頂き、何が原因なのかご教示頂けますでしょうか? 宜しくお願い致します。 Dim myRng As Range Dim i As Long Dim j As Long Dim k As Long j = 100 With ActiveSheet Set myRng = .Range("A1", .Cells(Rows.Count, "L").End(xlUp)).Resize(, 16) For i = 1 To myRng.Columns.Count If i = 11 Then .Columns(i).AutoFit End If Next i With .PageSetup .PrintArea = myRng.Address .Orientation = xlLandscape .PaperSize = xlPaperA4 .Zoom = j Do k = Application.ExecuteExcel4Macro("COLUMNS(GET.DOCUMENT(65))") If k = 1 Then Exit Do j = j - 1 .Zoom = j '”ここで実行時エラー1004” PageSetupクラスのZoomプロパティを設定できません” Loop End With .PrintOut Preview:=True .PageSetup.Zoom = 100 End With
- ベストアンサー
- Excel(エクセル)
- VBAでオートフィルを使って指定する文字列を含むものを表示させたい
VBAを使って、セルD1に入力した文字列を検索するマクロを作りたいと思っています。 私は初心者で前に似たようなものを作ってもらって それを加工しようとしたのですが、うまくいきませんでした。 以前は完全に一致するもので表示でしたが、 今回は含むものを表示させたいです。 ワイルドカードは*をつけるのはわかるのですが、 いろいろやってみましたがダメでした。(単純なことかもしれないですけど) Private Sub Worksheet_Change(ByVal Target As Range) Dim myRng1 As Range Dim myRng2 As Range Set myRng1 = Target.Cells(1) If Application.Intersect(myRng1, Range("D1")) Is Nothing Then Exit Sub Set myRng2 = Range("D1").CurrentRegion With myRng2 If myRng1 = "" Then ActiveSheet.ShowAllData Else .AutoFilter Field:=4, Criteria1:=myRng1.Value End If End With End Sub
- 締切済み
- その他(プログラミング・開発)
- エクセルのマクロ
下記のマクロを実行するといつも.Findのところでフリーズしてしまいます。 同じ方法で違うBookからの取込には不具合はないのですが、何故だかわかりません。 ちょっと長くなりますが、どなたか教えてください。 'Function fn_KAKUNIN_Update(strSheetName As String, strInBookName As String) '変数宣言 Dim wksInSheet As Worksheet '入力シート Dim wkbInBook As Workbook '入力ブック Dim wksUpSheet As Worksheet '更新するシート Dim lngKAKUNIN_MaxRow As Long Dim lngSYACHO_MaxRow As Long Dim intMsg As Integer Dim strGenbaNo As String Dim i As Long Dim j As Long Dim rngFind As Range Dim lngStrNo As Long Set wkbInBook = Workbooks(strInBookName) Set wksInSheet = wkbInBook.Worksheets Set wksUpSheet = Workbooks(pstrBookName).Worksheets(strSheetName) fn_KAKUNIN_Update = 1 lngKAKUNIN_MaxRow = wksInSheet.Range("C4").CurrentRegion.Rows.Count lngSYACHO_MaxRow = wksUpSheet.Range("H4").CurrentRegion.Rows.Count lngStrNo = 4 For i = lngStrNo To lngSYACHO_MaxRow strGenbaNo = wksUpSheet.Range("H" & i) With wksInSheet.Range("C4:C" & lngKAKUNIN_MaxRow) Set rngFind = .Find(strGenbaNo, LookIn:=xlValues, MatchCase:=False) If rngFind Is Nothing Then Else
- 締切済み
- Visual Basic
- エクセル VBA セルの色をSheet1とSheet2の両方を変えたいのですが・・・
最近困っているところが表題の通りなのですが Sheet1のB2を右クリックするとB2のセルの色を変えて Sheet2のB2のセルも色を変えたいというものです。 現状で Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) Dim Rng As Range, myRng As Range Dim RngA As Range, myRngA As Range Set Rng = Range("B3:W3,b7:w8,b12:w12,d13:w13,d17:w18,d22:w23") Set myRng = Intersect(Target, Rng) If myRng.Interior.ColorIndex = xlColorIndexNone Then myRng.Interior.ColorIndex = 37 Else If myRng.Interior.ColorIndex = 37 Then myRng.Interior.ColorIndex = 45 Else myRng.Interior.ColorIndex = xlColorIndexNone End If End If Cancel = True End Sub とここまではあるのですが、これをどう改造すればSheet2の同じセルの色もかわるのでしょうか? 宜しくお願いいたします
- ベストアンサー
- オフィス系ソフト
- エクセル2010でマクロが動きません
こんにちは。 マクロ超初心者です。 頑張ってエクセル2016でマクロ作成しましたが、エクセル2010で途中から動かず…。 何が悪いんでしょうか… ここから動きません…と書いたところから動きません(涙) Private Sub シート編集_Click() Application.ScreenUpdating = False Dim i Dim Sh1 As Worksheet Dim Sh2 As Worksheet Dim Sh4 As Worksheet Set Sh1 = Worksheets("あ") Set Sh2 = Worksheets("い") Set Sh4 = Worksheets("う") Dim dayCutoff As Date dayCutoff = Application.InputBox("年月日を入力してください", "お支払期限 年月日を入力", Format(Date, "yyyy/mm/dd")) Sh4.Range("D12").Value = DateSerial(Year(dayCutoff), Month(dayCutoff) + 2, 0) 'お支払期限 dayCutoff = Application.InputBox("年月日を入力してください", "請求書発行 日を入力", Format(Date, "yyyy/mm/dd")) Sh4.Range("AC3").Value = Format(Date, "yyyy/mm/dd") '発行日 Sh1.Cells.Clear With Sh1 'edit .Range("A2") = "番号" .Range("B2") = "会社名" .Range("C2") = "判定" .Range("D2") = "契約番号" .Range("E2") = "拠点" .Range("F2") = "税率" .Range("G2") = "月額(税抜)" .Range("H2") = "消費税" .Range("I2") = "月額(税込)" .Range("J2") = "今回" .Range("K2") = "全回" .Range("L2") = "店番" ここから動きません………… For i = 3 To Sh2.Cells(.Rows.Count, 1).End(xlUp).Row .Cells(i, 1) = Sh2.Cells(i, 2) .Cells(i, 2) = Sh2.Cells(i, 4) .Cells(i, 4) = Sh2.Cells(i, 3) .Cells(i, 5) = Sh2.Cells(i, 4) & "(" & Sh2.Cells(i, 6) & ")" .Cells(i, 6) = Sh2.Cells(i, 9) & "%課税" .Cells(i, 7) = Sh2.Cells(i, 8) .Cells(i, 8) = Sh2.Cells(i, 10) .Cells(i, 9) = Sh2.Cells(i, 11) .Cells(i, 10) = Sh2.Cells(i, 12) .Cells(i, 11) = Sh2.Cells(i, 7) .Cells(i, 12) = Sh2.Cells(i, 2) If Sh1.Cells(i, 10) > Sh1.Cells(i, 11) Then .Cells(i, 3) = "×" Else .Cells(i, 3) = "〇" End If If Sh1.Cells(i, 3) = "×" Then .Cells(i, 2) = "" End If Next i End With '空白行を削除 Dim j As Integer, myFlag As Boolean Dim c As Range With Worksheets("edit").Range("A2").CurrentRegion For j = .Rows.Count To 2 Step -1 myFlag = False For Each c In .Cells(j, 2) If c.Value <> "" Then myFlag = True Exit For End If Next If myFlag = False Then .Rows(j).Delete End If Next End With MsgBox "データの転記が終わりました" End Sub
- 締切済み
- Visual Basic
- エクセルのマクロについて
行を選択し、関数を数値に変換するために下記のようなマクロを作成しました。 選択する行数が少ないと実行でるのですが、一度にたくさんの行を選択すると下のようなエラーが返されます。 「実行時エラー"424"」オブジェクトが必要です。 どこが間違いなのか教えて頂ければ助かります。 Sub TextValue() '選択された行範囲をデータに変換します。 Dim rc As Integer Dim rngCell As Range Dim sMsg As String rc = MsgBox("データに変換しますか?", vbOKCancel) If rc = vbCancel Then Exit Sub sMsg = "変換する範囲を選択して下さい。" Set rngCell = Application.InputBox(Prompt:=sMsg, Type:=8) rc = MsgBox("選択されている範囲の関数を" & vbCrLf & "データに変換します。" & vbCrLf & _ "選択された行範囲は " & rngCell.Address(0, 0) & vbCrLf, _ vbOKCancel, "処理を確認してください。") If rc = vbCancel Then Exit Sub rngCell.Select Selection.Value = Selection.Value End Sub Excel2002 OSはXPです。 宜しくお願い致します。
- ベストアンサー
- Visual Basic
- excelのマクロで2007だとエラーが。
excel2003では動いていたマクロが2007では、エラーになってしまいます。 中断→デバッグ→再開→中断→デバッグ→再開、、、、 と中断しながらも10~20行ずつ進みます。 解決法がありましたら教えてください。 ※デバッグで確認すると「end if」で中断します。 Sub 仕分() Dim n As Long Dim nRow As Long Worksheets("シート名").Activate nRow = Range("A1").End(xlDown).Row For n = 2 To nRow If Cells(n, 6) = "条件1" Then Cells(n, 22) = "仕分け" ElseIf Cells(n, 6) = "条件2" Then Cells(n, 22) = "仕分けしない" ElseIf Cells(n, 6) = "条件1" And Cells(n, 7) = "条件2" Then Cells(n, 22) = "仕分け2" Else Cells(n, 22) = "OK" End If Next n End Sub
- ベストアンサー
- その他MS Office製品
- マクロ エクセル2003
いつも回答して頂き感謝しています。 原紙のブックを開き、別の名前を付けて保存するマクロを考えています。 原紙のブックを開くマクロはネットから探して、少し修正して出来あがったのですが、 この開いた原紙のブックに別の名前を付けて保存するマクロで困っています。 ただ単に名前を付けるだけだったら問題無いのですが、 その名前が既に保存されていないか確認した後、保存としたいのです。 ブックを開く記述を少し引用して出来ないかやってみたのですが、 Const Target2 As String = "C:\Users\Owner\Documents\" & NewFile で、定数式が必要です。と表示されエラーが発生してしまいます。 どのように変更したら上手くいくのでしょうか?宜しくお願い致します。 Sub Sample() Dim buf1 As String Dim buf2 As String Dim NewFile As String Dim ws1 As Worksheet Dim wb As Workbook Set ws1 = ThisWorkbook.Worksheets("作成") NewFile = "借入貸出" & ws1.Range("C4").Value & "." & ws1.Range("D4").Value Const Target1 As String = "C:\Users\Owner\Documents\借入貸出原紙.xlsx" Const Target2 As String = "C:\Users\Owner\Documents\" & NewFile & ".xlsx" buf1 = Dir(Target1) If buf1 = "" Then MsgBox Target1 & vbCrLf & "は存在しません", vbExclamation Exit Sub End If For Each wb In Workbooks If wb.Name = buf1 Then Application.DisplayAlerts = False Workbooks("借入貸出原紙.xlsx").Close Application.DisplayAlerts = True End If Next wb Workbooks.Open Target1 buf2 = Dir(Target2) If buf2 = "" Then End If End Sub
- 締切済み
- Excel(エクセル)
お礼
ありがとうございます。 ご指摘の通り、空白セルはあります。 又、思い当たることもありますので 帰宅後やってみます。いつも皆さんに 助けられ、本当に感謝です。この場をお借りして・・
補足
実際にやってみました。やはり仰っていたとおり 空白セルの分までカウントしていました。 また、赤フォントセルカウントは 100%、私の欲していた物で、助かりました。 今後も、何かありましたら、よろしくお願い致します。