Excel VBAコードでのエラーを解決する方法

このQ&Aのポイント
  • この質問では、Excel VBAのコードで間違った結果が返ってくる問題について説明されています。筆者はB9セル以下のB列の奇数番号に任意の数字が入っている場合、H列からP列の数値が入っているセルの数をカウントしたいと考えています。しかし、現在のコードは間違った結果を返しており、筆者はどこが間違っているのか分かりません。解決策をお求めです。
  • 筆者はExcel VBAのコードを作成しましたが、間違った数値が返ってくる問題に直面しています。具体的には、B9セル以下のB列の奇数番号に任意の数字が入っている場合、H列からP列の数値が入っているセルの数をカウントしたいと考えています。しかし、現在のコードは正しい結果を得ることができません。どこを修正すれば良いのか、アドバイスをお願いします。
  • Excel VBAのコードで問題が発生しており、正しい結果が得られません。具体的には、B9セル以下のB列の奇数番号に任意の数字が入っている場合、H列からP列の数値が入っているセルの数をカウントしたいと考えています。現在のコードでは、間違った数値が返されてしまいます。解決策を教えてください。
回答を見る
  • ベストアンサー

作成したコードの間違っている箇所が分かりません。

Excel VBAのコードを作成したのですが、間違った数値が返ってきてしまいます。 どこが間違っているのか分からず困っています。 お力を貸していただければと思います。 B9セル以下のB列の奇数番号(B9,B11,B13・・・)に任意の数字(1~9)が入っています。 その数字が3または5の場合、その行のH列からP列の数値が入っているセルの数をカウントしたく思っています。 (H列からP列には空欄または時刻のデータが入っています。) また、シートが20枚ほどあり、すべてのシートで同じ作業を行い、最終的には別シートを作成し、A列にシート名、B列にカウントしたセルの数を表示させます。 ちなみに全シート、データはA列からP列、1行目から120行目くらいまで入っています。(空欄のセルもあります。) 以下がコードです。 Sub Try1() Dim sumSheet As Worksheet Dim ws As Worksheet Dim i As Long, LastRow As Long Dim n As Long, nCount As Long '集計シートの作成 With ActiveWorkbook.Worksheets On Error Resume Next Set sumSheet = .Item("sum") On Error GoTo 0 If sumSheet Is Nothing Then Set sumSheet = .Add(After:=.Item(.Count)) sumSheet.Name = "sum" Else sumSheet.UsedRange.ClearContents End If ReDim res(1 To .Count - 1, 1 To 2) End With '集計 n = 0 For Each ws In ActiveWorkbook.Worksheets If ws.Name <> "sum" Then With ws LastRow = .Cells(.Rows.Count, 2).End(xlUp).Row nCount = 0 For i = 9 To LastRow Step 2 Select Case .Cells(i, 2).Value Case 3,5 nCount = nCount + WorksheetFunction.Count(.Cells(i, 8).Resize(, 9)) End Select Next n = n + 1 res(n, 1) = .Name res(n, 2) = nCount End With End If Next sumSheet.Range("A1").Resize(n, 2).Value = res sumSheet.Activate MsgBox "集計しました" End Sub VBA初心者です。よろしくお願いいたします。

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

  • ベストアンサー
  • layy
  • ベストアンサー率23% (292/1222)
回答No.1

ソースをじっくりみたわけでないですが、0の値までカウントして表示されましたからそこでは?。

関連するQ&A

  • Excel VBAで文字列の部分一致の文字列を表示

    以前、こちらで頭5文字までの一致で文字列を表示するVBAを教えて頂きました。今回はFINDなどの部分一致での文字列を表示することをしたいのですが、ご教示いただけますと幸いです。 下記はSheet1のA3に文字を5文字以内いれるとSheet2のC列からピックアップしてSheet1のA列に文字列を表示する及びSheet2のB列のデータをSheet1のC列に表示させるVBAです。 Sub Test2() Dim Ws1 As Worksheet, Ws2 As Worksheet Dim SData As String, i As Long, VRet As Variant Dim c As Range, LastRow As Long Set Ws1 = Sheets("Sheet1") Set Ws2 = Sheets("Sheet2") SData = CStr(Ws1.Range("A3").Value) If SData = "" Then Exit Sub i = 5 LastRow = Ws1.Cells(Rows.Count, "A").End(xlUp).Row If LastRow < i Then LastRow = i End If Ws1.Range(Ws1.Cells(i, "A"), Ws1.Cells(LastRow, "C")).ClearContents With Ws2 For Each c In .Range(.Cells(1, "C"), .Cells(Rows.Count, "C").End(xlUp)) VRet = InStr(1, CStr(c.Value), SData, vbTextCompare) If VRet = 1 And Len(c.Value) >= 10 Then Ws1.Cells(i, "A").Resize(1, 2).Value = c.Resize(1, 2).Value 'とりあえずSheet2のB列のデータ(C列のデータに同期したデータ)をSheet1のC列に Ws1.Cells(i, "C").Value = .Cells(c.Row, "B").Value i = i + 1 End If Next End With End Sub 宜しくお願い致します。

  • エクセル マクロ修正

    シート1~5まであります。別に情報シートを作成しています それぞれ同じ原本から作成しています 全部のシートにA1~A10のセルに日付、B1~B10のセルに文字など入力がするところがあります 入力はA1から順番に入れていきます 例えば 保存ボタンを作成しておく シート1のA1に日付、B1に”文字”を入力し、保存ボタンをおす 情報シートに日付と内容が一致する情報がなければ、 情報シートのA列にシート名、B列に日付、C列に入力した内容が 空白のところに出力される ボタンのマクロがCommandButton1_Clickとしたら Private Sub CommandButton1_Click() 検索 End Sub 標準モジュールに Sub 検索() Dim c As Range Dim ws1 As Worksheet Dim ws2 As Worksheet Dim ws1LastRow As Long Dim ws2LastRow As Long Set ws1 = Sheets("情報シート") Set ws2 = ActiveSheet If ws2.Range("A1").Value = "" Or ws2.Range("B1").Value = "" Then MsgBox "検索する日付もしくは語句が入力されていません。", vbCritical Exit Sub End If If ws1.Range("A1").Value = "" Then ws1LastRow = 0 Else ws1LastRow = ws1.Cells(Rows.Count, "A").End(xlUp).Row End If ws2LastRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row For Each c In ws1.Range(ws1.Cells(1, "B"), ws1.Cells(Rows.Count, "B").End(xlUp)) If c.Value2 = ws2.Cells(ws2LastRow, "A").Value2 Then If c.Offset(0, 1).Value = ws2.Cells(ws2LastRow, "B").Value Then MsgBox "既にデータが存在します", vbInformation Exit Sub End If End If Next ws1.Cells(ws1LastRow + 1, "A").Value = ws2.Name ws1.Cells(ws1LastRow + 1, "B").Resize(1, 2).Value = ws2.Cells(ws2LastRow, "A").Resize(1, 2).Value MsgBox "データを追加しました", vbInformation Set ws1 = Nothing Set ws2 = Nothing End Sub これを教えて頂き作っていたのですが 別のシートを作成しこのプログラムを応用していたのですが うまく起動しないため再度投稿しました 今度のやつは固定でやろうと思っていていじったのですが 別の欄の文字が表示してしまった 結合セルB2:C4に日付を入れる 結合セルL2:L30に内容を入れるようにしたいのですが ここだけのセルを参照するようにしたいのです。 どうすればいいでしょうか? 試したことAをB2にかえ、BをL2にしたら変なことになりました・・・

  • マクロ 入力する文字に色を付けたい

    Sub CountUp(ByVal mCol1 As String, mCol2 As String) Dim LastRow1 As Long Dim LastRow2 As Long Dim mRow As Long With Sheets("プレーヤー") LastRow1 = .Cells(Rows.Count, mCol1).End(xlUp).Row LastRow2 = .Cells(Rows.Count, mCol2).End(xlUp).Row If LastRow1 > LastRow2 Then mRow = LastRow1 Else mRow = LastRow2 End If If LastRow1 = 1 Then LastRow1 = 2 End If .Cells(mRow + 1, mCol1).Value = .Cells(LastRow1, mCol1) + 1 End With End Sub このコードに文字の色の指定をしたいです Selection.Font.ColorIndex = 3を入れたら赤色文字で入力できるかなと思ったのですがうまくいきませんでした(エラーにはならないのですが、色が付かなかったです)

  • VBA マクロ シート 転記

    はじめまして。VBA初心者です。今シート1のA列1行目セルにA社、A列2行目にB社、A列3行目にC社と・・ざっと1000行程あり、それぞれB列には値があります。この値をシート2のB列に転記したいと思っています。ただ、毎月シートを追加していきますので、左隣のシートから転記しなければなりません。シート2の項目は同じA列とB列で構成されています。A列の値が多少前後するので、FINDを使って以下のようなプログラムを作りました。ただ、左隣のシートから転記とう内容をどうやって追加したら良いのかがわかりません。Previous をどこかに使えばできるのかなとも思うのですが、その方法がわかりません。 Sub 転記() Dim ws As Worksheet, ws1 As Worksheet, r As Range, r1 As Range Dim LastRow As Long, i As Long, er As Long, wkey As String Set ws = Worksheets("Sheet1") Set ws1 = Worksheets("Sheet2") LastRow = ws.Range("A1").End(xlDown).Row er = ws1.Range("A1").End(xlDown).Row Set r = ws.Range("A1:A" & LastRow) For i = 1 To er wkey = ws1.Range("A" & i) Set r1 = r.Find(What:=wkey, LookIn:=xlValues, LookAt:=xlWhole) If Not r1 Is Nothing Then ws1.Range("B" & i) = r1.Offset(, 1) End If Next Set r1 = Nothing Set r = Nothing Set ws = Nothing Set ws1 = Nothing End Sub どなたか詳しいお方いらっしゃいましたら、初心者の私に教えて頂けませんでしょうか?宜しくお願いします。

  • VBA 1行目のフィルターが外れてしまいます

    大変お世話になっております。 Book_元にVBAのコードを保存しております。 以下のコードですと、Book_元の全てのシートの1行目のフィルターが最後に無くなってしまいます。 そして、コピー・貼り付けをする ’ミス’ 以外の項目しかないシートは1行目が、Book_先に貼りついてしまいます…。 そして、ws.AutoFilterMode = True でエラーとなってしまいます。 修正をしていただき、コード全文をご記載いただけると大変有難いです…。 Sub Macrosubete() Dim sourceWorkbook As Workbook Dim destWorkbook As Workbook Dim destSheet As Worksheet Dim lastRow As Long Dim sourceRange As Range Dim ws As Worksheet Dim sheetNames As Variant ' コピー元のWorkbookを定義 Set sourceWorkbook = ThisWorkbook ' 貼り付け先のファイルを開く Set destWorkbook = Workbooks.Open("F:\Book_先.xlsm") ' シート名の配列を設定 sheetNames = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5", "Sheet6", "Sheet7", "Sheet8", "Sheet9", "Sheet10", "Sheet11", "Sheet12", "Sheet13") ' Sheet1からSheet13までの各シートに対してループを行う For Each ws In sourceWorkbook.Sheets If IsInArray(ws.Name, sheetNames) Then ' コピー元のデータの範囲を定義 With ws .Range("$C$1:$E$6").AutoFilter Field:=3, Criteria1:="ミス" lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row Set sourceRange = .Range("C2:E" & lastRow).SpecialCells(xlCellTypeVisible) End With ' 貼り付け先のシートを指定 Set destSheet = destWorkbook.Sheets(ws.Index) ' 貼り付け先のセルを指定してデータを貼り付け With destSheet lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row sourceRange.Copy .Range("C" & lastRow + 1) End With ' オートフィルターを解除 If ws.AutoFilterMode Then ws.AutoFilterMode = False End If End If Next ws ' 全体のシートに対してオートフィルターを再度適用 For Each ws In sourceWorkbook.Sheets If IsInArray(ws.Name, sheetNames) Then ws.AutoFilterMode = True End If Next ws ' コピー元のファイルをアクティブにする sourceWorkbook.Activate End Sub Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1) End Function 大変恐縮ですが、心よりご回答をお待ちしております。 どうぞ宜しくお願い申し上げます。

  • VBA 検索するSheetの位置の変更

    現在、グループの数だけユーザー名の合計数をSheet2に抽出するという 事をやっているのですが....... コードの方は下記になります Sub Sample3() Dim i As Long, j As Long, k As Long, lastRow As Long, lastCol As Long Dim wS2 As Worksheet, wS3 As Worksheet Set wS2 = Worksheets("Sheet1") Set wS3 = Worksheets("Sheet2") Application.ScreenUpdating = False If wS2.Range("Y1") = "" Then wS2.Range("Y1") = "ダミー" End If With Worksheets("Sheet1") If .Range("A4") = "" Then .Range("A4") = "ダミー" End If lastRow = .Cells(Rows.Count, "B").End(xlUp).Row Range(.Cells(5, "B"), .Cells(lastRow, "B")).AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True '★ For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row wS2.Cells(7, (i - 2) * 8 + 3) = wS3.Cells(i, "A") .Range("A4").AutoFilter field:=2, Criteria1:=wS3.Cells(i, "A") Range(.Cells(5, "AA"), .Cells(lastRow, "AA")).SpecialCells(xlCellTypeVisible).Copy wS2.Cells(7, (i - 2) * 8 + 2) For k = wS2.Cells(Rows.Count, (i - 2) * 8 + 2).End(xlUp).Row To 7 Step -1 wS2.Cells(k, (i - 2) * 8 + 3) = WorksheetFunction.CountIfs(.Range("AA:AA"), wS2.Cells(k, (i - 2) * 8 + 2), .Range("B:B"), _ wS2.Cells(7, (i - 2) * 8 + 3)) If WorksheetFunction.CountIf(wS2.Columns((i - 2) * 8 + 2), wS2.Cells(k, (i - 2) * 8 + 2)) > 1 Then wS2.Cells(k, (i - 2) * 8 + 2).Resize(, 2).Delete shift:=xlUp End If Next k Next i wS2.Range("B1").CurrentRegion.Borders.LineStyle = xlContinuous wS2.Cells.Replace what:="ダミー", replacement:="", lookat:=xlWhole .Cells.Replace what:="ダミー", replacement:="", lookat:=xlWhole wS3.Cells.Clear .AutoFilterMode = False End With Application.ScreenUpdating = True End Sub このコードで検索をかけるSheet1のセルBの文字をセルCに移動して検索かけたいという事なのですが、下記の用なコードでBをCに変更してみた結果エラーが発生してしまいます。 lastRow = .Cells(Rows.Count, "C").End(xlUp).Row Range(.Cells(5, "C"), .Cells(lastRow, "C")).AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True '★ For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row wS2.Cells(7, (i - 2) * 8 + 3) = wS3.Cells(i, "A") .Range("A4").AutoFilter field:=2, Criteria1:=wS3.Cells(i, "A") Range(.Cells(5, "AA"), .Cells(lastRow, "AA")).SpecialCells(xlCellTypeVisible).Copy wS2.Cells(7, (i - 2) * 8 + 2) For k = wS2.Cells(Rows.Count, (i - 2) * 8 + 2).End(xlUp).Row To 7 Step -1 wS2.Cells(k, (i - 2) * 8 + 3) = WorksheetFunction.CountIfs(.Range("AA:AA"), wS2.Cells(k, (i - 2) * 8 + 2), .Range("C:C"), _ どなたかご教授の方お願い致します。

  • VBAで複数列からの条件指定でデータを抽出したい

    講習会の受講者名簿を作成しています。(名簿は科目別で3つのシートに分かれています。) 現在下記モジュールで、受講者名・受講者番号を個々に入力し検索出来るようにしていますが、 受講日(例:2014/4/1~2014/4/31の間)で受講者を抽出できるようにしたいと考えています。 しかし、受講予定日は過去のものも含め複数列(I列~N列)まであり、受講者によって受講日の入力されている列がI列~N列間でまちまちです。 このような場合、どのようにVBAを変更したら受講日で検索が可能になるでしょうか? 宜しくお願いします。 Sub Sample2() Dim k As Long, endRow As Long, wS As Worksheet Set wS = Worksheets("検索&抽出") If wS.Range("B1") = "" And wS.Range("B2") = "" Then MsgBox "検索データを入力してください" Exit Sub End If endRow = wS.Cells(Rows.Count, "A").End(xlUp).Row If endRow > 4 Then wS.Rows(5 & ":" & endRow).ClearContents End If For k = 2 To 4 With Worksheets(k) If wS.Range("B1") <> "" Then .Range("A1").AutoFilter field:=2, Criteria1:=wS.Range("B1") End If If wS.Range("B2") <> "" Then .Range("A2").AutoFilter field:=3, Criteria1:=wS.Range("B2") End If If .AutoFilter.FilterMode Then endRow = .Cells(Rows.Count, "A").End(xlUp).Row If endRow > 2 Then Range(.Cells(3, "A"), .Cells(endRow, "N")).Copy wS.Cells(Rows.Count, "A").End(xlUp).Offset(1) End If .AutoFilterMode = False End If End With Next k End Sub

  • エクセルVBA  どうしても動きません。

    お世話になります。 なかなか上達しない超初心者です。 ↓↓ですが、Activesheetにすると動くのに、シート名を元々存在するシート”実験"に指定すると動きません(データ内容はまったく同じで、A列に色んな名前が入っていて、重複しているとC列に重複と入力します)。 2日間試行錯誤したのですが、やっぱり動かず・・・ ちなみに、Activateにするとアクティブになるし、CurrentRegionも選択できるのに なんでうごかないんでしょうか・・・ 何卒ご指導くださいませ。よろしくお願いいたします!!!!!! Sub Test2() With Sheets("実験").Range("A1").CurrentRegion Dim i As Long Dim LastRow As Long LastRow = Range("A" & Rows.Count).End(xlUp).Row For i = 1 To LastRow If WorksheetFunction.CountIf(Range("A:A"), Cells(i, 1)) > 1 Then Cells(i, 3) = "重複" End If Next i End With End Sub Sheets("実験")をActivesheetに変えると別のシートがしっかり動いてくれます・・・が、なんとしてでも”実験”シートに動いていただきたいです・・・。

  • 休暇願をVBA作成し両面印刷する方法を教えてほしい

    VBAで休暇願を作成し印刷時は差し込み印刷方法でA4用紙に両面印刷したいのですが書き方が判りません。 マクロの内容を添付しますので両面印刷できるようにするにはどのように書けばよいのか教えてください。 下記のマクロで片面印刷は可能です。 Sub 印刷() Dim LastRow As Long Dim i As Long Dim myNo As Long If vbNo = MsgBox("印刷を開始していいですか?", vbYesNo) Then Exit Sub With Worksheets("名簿マスター") LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row For i = 1 To LastRow myNo = .Range("A" & i).Value With Worksheets("印刷シート") .Range("f7").Value = myNo .PrintOut Copies:=1, Collate:=True End With Next i End With MsgBox "印刷が終わりました" End Sub

  • 再質問 エクセルの表の列の最下行から指定数の・・

    お世話になっております。 3日前にここでご回答いただいて解決したと思ったのですが、実シートで作業開始早々に不都合が出たので追加のHELPのお願いです。 各列の17行目以降に行方向にデータが入った表の下から30個のデータのMaxを求める関数のVBAを教わって早々に作業を開始したのですが、なぜか最下行を含まないVBAと、計算式の入った列では結果が「#VALUE!」となり、最下行を含むVBAの場合は、計算式の入った列の結果は「0」となってしまいます。 試しに別のシートで数値の列とその数値に定数をかけた列を作って試してみましたがうまく行きます。 また、対象のシートのセルの書式は数値になっています。 具体的な数式は =IF(F127="","",F127*5) というような単純な計算式で日付が入るような特殊な計算はやっていません。 項目 数値A 計算値A 数値B 数値B 数値C ------------------------------------------------------------------- 平均 1.1197 #VALUE! 46.6133 #VALUE! 44.6767 σ 0.0008 #VALUE! 2.5940 #VALUE! 0.2128 最小 1.117 0.000 42.100 0.000 44.300 最大 1.121 0.000 51.100 0.000 45.100 <最下行を含む場合> Function sfMax(Rng As Range, Optional bd) As Double Dim LastRow As Long Dim MyCol As Long Dim tgRng As Range Dim Border As Long Dim StartRow As Long Const DefBorder = 30 StartRow = 17 'データ開始行 If IsMissing(bd) Then Border = DefBorder '省略された場合の閾値 Else If ((bd = 0) Or (bd = "")) Then Border = DefBorder '省略された場合の閾値 Else Border = bd End If End If MyCol = Rng.Column LastRow = Cells(Rows.Count, MyCol).End(xlUp).Row If LastRow > StartRow + Border - 1 Then StartRow = LastRow - Border + 1 End If Set tgRng = Range(Cells(StartRow, MyCol), Cells(LastRow, MyCol)) sfMax = WorksheetFunction.Max(tgRng) End Function <最下行を副含まない場合> Function sfSTDEV(Rng As Range, Optional bd) As Double Dim LastRow As Long Dim MyCol As Long Dim tgRng As Range Dim Border As Long Dim StartRow As Long Const DefBorder = 30 StartRow = 17 'データ開始行 If IsMissing(bd) Then Border = DefBorder '省略された場合の閾値 Else If ((bd = 0) Or (bd = "")) Then Border = DefBorder '省略された場合の閾値 Else Border = bd End If End If MyCol = Rng.Column LastRow = Cells(Rows.Count, MyCol).End(xlUp).Row If LastRow > StartRow + Border - 1 Then LastRow = LastRow - 1 StartRow = LastRow - Border + 1 End If Set tgRng = Range(Cells(StartRow, MyCol), Cells(LastRow, MyCol)) sfSTDEV = WorksheetFunction.StDev(tgRng) End Function

専門家に質問してみよう