• 締切済み

VBAで統計プログラムを作成しています。

現在VBA（Excel)にて統計のプログラムを作成しています。 Sheet２に統計表 統計対象のシートはシートタブの色が赤色(枚数不特定) 統計表の縦軸には、B４～15に４～３(１年度の月)。横軸にはF～J４に１～５。 統計対象シートの構成は同じで セルE4に１～５の数字のどれか セルE24には１～12の数字のどれかが入ります 統計表イメージ A　　　 B 　　　C 　　　D １　　　 １　　　 ２　　　 ３ ２ ４月 ３ ５月 ４ ６月 ５ ７月 入力画面（シート名部分赤シート） E4 ←１～５のどれか E24 ←１～１２のどれか この場合において、たとえばE4が"１"、E24が"４"だった場合 統計表のB2にカウントされるというプログラムが作りたいのですが、 Option Explicit Private Sub CommandButton2_Click() Dim Ws As Worksheet Dim cnt　As　Variant Dim grade() As Variant 'grade = grd = 学年 grade = Array("1", "2", "3", "4", "5") Dim month() As Variant 'month = mnt = 月 month = Array("4", "5", "6", "7", "8", "9", "10", "11", "12", "1", "2", "3") Dim grd As Integer '各変数宣言 Dim mnt As Integer Dim set1 As Integer Dim set2 As Integer Dim 月ー所 As Worksheet For grd = 1 To 5 If Cells(4, 5).Value = grade(grd - 1) Then cnt = 0 set1 = grd + 5 End If For mnt = 1 To 12 If Cells(24, 5).Value = month(mnt - 1) Then set2 = mnt + 3 End If 　 For Each Ws In Worksheets If Ws.Tab.ColorIndex = red Then cnt = cnt + 1 End If Next Worksheets("月ー所").Cells(set2, set1).Value = cnt ←この行でエラー1004 Next mnt Next grd MsgBox "統計しました。" End Sub 矢印で示した行のエラー1004の解除方法が分からず悩んでいます どうかよろしくお願いいたします。

みんなの回答

  • tgook
  • ベストアンサー率48% (96/198)
回答No.4

コード見ていて気になったのですが、エラー1004 の出るというところのコードが以下のようになっていると思います。 > Worksheets("月ー所").Cells(set2, set1).Value = cnt Excelファイル内には 月ー所 という名前のワークシートがあるのですか？ 変数宣言箇所で、月ー所 という名前のWorksheetオブジェクトが宣言されています。 > Dim 月ー所 As Worksheet 何となく、月ー所 のWorksheetオブジェクト宣言、要らないのではないでしょうか？ エラー1004 は調べたら オブジェクト定義エラー ということみたいなので、これかな？と思いました。 ' を前に入力してコメント化した後、デバッグしてみてください。 あと、他の方の回答にある、変数「set2」または「set1」が　0の時 が無いとも限らない為、以下方法でデバッグも試してみてください。 (1)ブレークポイントをVBAエディタ上の停止したい所に設置。 VBAコードを入力するエディタの左側にグレー領域があります。 ここをクリックすることでブレークポイントが設置できます。 設置するとエディタのグレー領域に赤丸、コード箇所が赤く塗りつぶされます。 (2)メニューの 表示(V) → ローカルウィンドウ(S) で ローカルウィンドウ を開く。 (3)実行すると、ブレークポイントで一時停止状態になる。 (4)ローカルウィンドウに+Meと表示されるので、+Meをクリックまたはダブルクリックすると各変数の値が確認できるようになります。 試しにset1やset2を探してみてください。 (5)F8キーでステップ実行していくと変数の値がどのように変わるかが確認できます。

ponta521_1990
質問者

お礼

回答頂いたのに遅くなって大変申し訳ありませんでした。 参考にいたしまして無事プログラムを完成することができました。 本当にありがとうございました。

  • imogasi
  • ベストアンサー率27% (4737/17068)
回答No.3

統計といった大げさな題は不適当。 たんなる件数カウント程度とかではないか。 －－ エラー1004の解除方法 これも解除方法とは言わないとおもう。解消方法ならまだわかる。 デバッグとか、訂正・修正方法といったらよいのかな。エラーの解除と言えば、ＶＢＥ画面で、実行ーリセットなどのことではないかな。 ーーー エラーの出た直前行にset2, set1にどんな値が入っているか Ｍｓｇｂｏｘ　Ｓｅｔ１ & 　” " & Set2 を入れて、再度実行して、その表示の値を良く考えれば、不適当な原因はすぐ判る。 そこでそれ以前のset2, set1の設定情況をチェックする。 ーー 全般に基礎的なこと。 データ例でも挙げて、やりたいことを文章化すれば、もっと引き締まったコードを教えてもらえる気がする。

ponta521_1990
質問者

お礼

回答頂いたのに遅くなって大変申し訳ありませんでした。 質問の仕方が不十分で反省しております。 とても今後の参考になりました。 本当にありがとうございました。

  • mt2008
  • ベストアンサー率52% (885/1701)
回答No.2

1004のエラーは変数「set2」または「set1」が　0の時に発生していると思われます。 これらが0の時の処理を入れましょう。 ＃デバッグするときSTEP実行しながら行っていますか？

ponta521_1990
質問者

お礼

回答頂いたのに遅くなって大変申し訳ありませんでした。 set1と2が０の場合は頭にありませんでした。 回答本当にありがとうございました。

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

シート名 SET1 SET2 CNT のどれかがおかしいからエラー、なわけですから、そこから調べる。 正しく理解して記述したもの、あやふやで記述したもの、これ分けるだけでも多少絞り込める。 こういうのはできない？。 デバッグは？ CNTはEMPTYですね？

ponta521_1990
質問者

お礼

回答頂いたのに遅くなって大変申し訳ありませんでした。 今回デバッグ機能の使い方を学ぶことができました。 無事プログラムは完成することができました。 本当にありがとうございました。

  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. Visual Basic

関連するQ&A

  • ユーザー定義関数の再計算

    ユーザー定義関数を作りました。 ところが、この関数が自動再計算をしてくれません。 どうしたら自動再計算するようになるのでしょうか？ よろしくお願いします。 ちなにこの関数は、自分のシートのB2とsheet1～sheet4のB9を比較して、正しければB9の４つ右のセルの値を合計して返すものです。 =SheetLook($B$2,"sheet1,sheet2,sheet3,sheet4",B9,4) コードです。 Function SheetLook(参照元 As Variant, 比較対象シート As String, 比較対象セル As Range, 参照セル位置 As Integer) As Variant 　　Dim i As Integer 　　Dim rng As Range 　　Dim sss As Variant 　　Dim kei As Variant 　　Dim cnt As Integer 　　sss = Split(比較対象シート, ",") 　　kei = 0 　　cnt = 0 　　For i = 0 To UBound(sss) 　　　　Set rng = Sheets(sss(i)).Range(比較対象セル.Address) 　　　　If 参照元 = rng Then 　　　　　　kei = kei + rng.Offset(0, 参照セル位置) 　　　　　　cnt = cnt + 1 　　　　End If 　　Next 　　If cnt <> 0 Then 　　　　SheetLook = kei 　　Else 　　　　SheetLook = "" 　　End If End Function

  • VBA　マクロについて

    自作のカレンダーに自動で日付を判定、入力してくれる ロジックを作っていたのですが、 2、4、6、9、11月以外は31日分表示されるはずが。。。 表示されませんでした。 恐らくロジックがおかしくて i=31 が通っていないものと 思われますが、ちょっとよく分かりません。 初心者で低レベルな質問ですけど、どなたかお願いします。 Sub AutoCarender() '自動でカレンダーの日付を入力するプログラム Dim month, i As Integer '表示させたい月 month = 3 If (month = 2) Then i = 28 ElseIf (month = 4 Or 6 Or 9 Or 11) Then i = 30 Else i = 31 End If Dim tate, yoko As Integer Dim week As Integer week = (Weekday(2009 / month / 1, 2)) yoko = Choose(week, 1, 3, 5, 7, 9, 11, 13) tate = 3 For j = 1 To i '"シートの名前"を指定 Worksheets("Sheet1").Cells(tate, yoko).Value = j yoko = yoko + 2 If (yoko > 13) Then yoko = 1 tate = tate + 2 End If Next End Sub

  • 【VBA】別々のシートに列ごとコピーしていきたい

    エクセルＶＢＡ初心者です 以下のような表を、地区別にわけられたシートで、種別を選んで貼り付けていきたいのですが 地区 種別 1 大阪 金 2 東京 銀 3 名古屋 銀 4 大阪 金 5 大阪 銅 6 名古屋 銅 7 東京 金 8 名古屋 金 9 大阪 銅 金と銀のみ、地区に分けられたシートに貼り付け シート【大阪】 1 大阪 金 4 大阪 金 シート【東京】 2 東京 銀 7 東京 金 シート【名古屋】 3 名古屋 銀 8 名古屋 金 以下のVBAを加工してみましたが組んでみましたがうまくいきません どうかご教示のほどよろしくお願いします ↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓ Public Sub cptest() Dim sht1 As Worksheet Dim sht2 As Worksheet Dim rng As Range Dim cel As Range Dim stcrng As New Collection Dim lastRow As Integer Dim cnt As Integer Set sht1 = ThisWorkbook.Worksheets("Sheet1") Set sht2 = ThisWorkbook.Worksheets("Sheet2") lastRow = Range("G65535").End(xlUp).Row Set rng = sht1.Range("G1:G" & lastRow) For Each cel In rng If cel.Value = "あり" Then Set cel = sht1.Range(cel.Offset(0, -4), cel.Offset(0, -1)) stcrng.Add cel End If Next sht2.Cells.Clear cnt = 0 Set rng = sht2.Range("A1") For Each cel In stcrng cel.Copy rng.Offset(cnt, 0).PasteSpecial rng.Offset(cnt, 4).Value = "＿" cnt = cnt + 1 Next Application.CutCopyMode = False End Sub

  • VBA定義について

    ExcelでVBAを使用してデータを曜日に寄って抽出する様定義されているのをみました。 ところで下記のDim TBL_E(2, 31) As Integer はどういう意味かまた [XXX = 1: OFF_CELL = 14: CNT1 = 1: CNT2 = 1]ってたとえですか。意味はちょっと分かりません。 初心者の者ですがよろしくお願いします。 Dim TBL_E(2, 31) As Integer YOUBI = Worksheets("AAA").Range("C11") XXX = 1: OFF_CELL = 14: CNT1 = 1: CNT2 = 1 Do Until CNT2 >= 8 If XXX <> Worksheets("AAA").Cells(OFF_CELL, 3) Then Select Case YOUBI Case 1: Worksheets("BBB").Range("E3") = "日" Worksheets("AAA").Range("AE5") = "SUN" Case 7: Worksheets("BBB").Range("E3") = "土" Worksheets("AAA").Range("AE5") = "SAT"　　　　　　　　　 If CNT1 <= 8 Then TBL_E(1, CNT1) = XXX If CNT1 = 1 Then Worksheets("AAA").Range("D16") = YOUBI End If

  • EXCEL VBA作成方法

    職場で頭の痛いことがありまして・・・ 月合計をEXCELで1つのシートに出すことは出来ますが、それを日付ごとに（1日～31日）複数シートにする方法がわかりません。 内容は自分で工夫をして見ましたがうまくできません。ご教授をいただけますでしょうか？ Sub 月別シート分割() Dim 元シート As Worksheet Dim 列幅() As Variant Dim 条件列 As Integer Dim 月 As Long Dim 条件1 As String, 条件2 As String Dim i As Integer, j As Long Set 元シート = ActiveSheet ActiveCell.CurrentRegion.Select ReDim 列幅(Selection.Columns.Count) For i = 1 To Selection.Columns.Count 列幅(i) = Selection.Cells(, i).ColumnWidth Next 条件列 = 1 月 = Month(ActiveCell.Offset(1, 条件列 - 1)) If Selection.AutoFilter Then Selection _ .AutoFilter For i = 1 To 31 Sheets.Add Before:=Sheets(i) ActiveSheet.Name = i & "" 条件1 = ">=" & DateSerial(月, i, 1) 条件2 = "<" & DateSerial(月, i + 1, 1) 元シート.Activate ActiveCell.CurrentRegion.Select Selection.AutoFilter Field:=条件列 _ , Criteria1:=条件1 _ , Operator:=xlAnd _ , Criteria2:=条件2 Selection.SpecialCells( _ xlCellTypeVisible).Copy Sheets(i).Range("A1").PasteSpecial For j = 1 To Selection.Columns.Count Sheets(i).Cells(, j).ColumnWidth _ = 列幅(j) Next j Next i Selection.AutoFilter Sheets(1).Activate End Sub

  • macroについて教えてください

    こんにちは。以前こちらでPrivate SubについてMacroを教えていただきました。（あの後ログインパスワード等が不明になりお礼も出来ませんでしたが。。。回答頂いた方すみませんでした。） 下記がそのMacroですが、今回また少し変えることになり どのように変えていいのか分かりません。 前回は1～5はグレー、6～10は茶色・・・という形にしたのですが 今回は進捗率での管理をしたく、80％以下は白、80～90％は赤、90～100％は青としたいと思っています。 Private Sub Worksheet_Change(ByVal Target As Range) Dim iColors As Variant Dim rw As Long Dim CellCnt As Integer Dim col As Integer Dim col2 As Integer Dim i As Integer Dim j As Integer Dim k As Integer Dim c As Variant Dim ar() As Variant Dim Sh1 As Worksheet Set Sh1 = Worksheets("小児科Dr") col = Target.Cells(1).Column '制限された列 If Not (col = 4 Or col = 8 Or col = 12 Or col = 16) Then Exit Sub iColors = Array(16, 16, 16, 16, 16, 53, 53, 53, 53, 53, 54, 54, 54, 54, 54) CellCnt = Target.Count ReDim ar(CellCnt - 1) For Each c In Target If c.Value <> "" Then If IsNumeric(c.Value) Then i = c.Value If i >= 11 Then i = 10 End If If i > 0 And i < 11 Then j = iColors(i - 1) Else j = 2 End If ar(k) = j k = k + 1 End If End If Next c rw = Target.Row Select Case col Case 4: col2 = 2 Case 8: col2 = 8 Case 12: col2 = 14 Case 16: col2 = 20 'Sh1.Cells(rw + 2, 13).Resize(Int(Target.Count / 3), 3).Interior.ColorIndex = j End Select InsideColors Sh1, rw, col2, CellCnt, ar() Set Sh1 = Nothing End Sub Private Sub InsideColors(sh As Worksheet, _ rw As Long, _ col As Integer, _ cnt As Integer, _ ar As Variant) 'sh[シート],rw[行], col[列],cnt[セル個数],iColor[色指数] Dim i As Integer Dim j As Integer Dim n As Integer Dim k As Integer If cnt Mod 5 > 0 Then '範囲行数 i = (cnt + 5 - (cnt Mod 5)) / 5 Else i = cnt / 5 End If rw = Int((rw - 1) / 5) + 1 '行再設定 j = ((rw - 1) Mod 5) + 1 '列設定 For n = j To cnt sh.Cells(rw + 2, col).Resize(i, 5).Cells(n).Interior.ColorIndex = ar(k) k = k + 1 Next n End Sub 毎回他の人を頼ってしまい、申し訳ないのですがお願いします。 また、前回分からなかったので1～5を指定するときに5回同じカラー番号を書いたのですがこちらも良かったら手直し方法を教えていただければ助かります。 宜しくお願いします。

  • ExcelのVBAについてです。シート1と2を作成

    ExcelのVBAについてです。シート1と2を作成し、シート1にバーコードまたはキーボードで入力します。シート1は入力専用かつ入力した分の早見表で、実際にはシート2に転記仕訳して、シート3以降に表を作成したいです。使い方はシート1に入力またはシート2をタップまたはクリックすると入力(画面)になります。以前の質問の回答を参考に必要最低限に改良しています。パッと見で構いません、何か不具合は見付からないでしょうか？ '///Sheet1/// Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim time7 As Range For Each time7 In Target If time7.Column = 1 Then time7.Offset(0, 4).Value = Format(Now, "Short Time") & vbCrLf & _ Format(Now, "yyyy/mm/dd hh:nn:ss AM/PM") End If Application.EnableEvents = False Application.EnableEvents = True Next time7 '(1)シートを変数にセット Dim ws1 As Worksheet Dim ws2 As Worksheet Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") '(2)シートを指定してデータを転記 ws2.Range("A3:H3").Value = ws1.Range("A3:H3 ").Value End Sub Private Sub Worksheet_Activate() ' ' 新規行挿入 ' ' Worksheets("Sheet2").Range("3:3").Insert Sheets("Sheet1").Range("H3").Select ActiveCell.FormulaR1C1 = "5" Sheets("Sheet1").Range("E3").Select Selection.ClearContents Dim str_Left As String 'セルE4に文字列、セルH4に数字を予め入れておくこと。 str_Left = Left(Cells(4, 5), Cells(4, 8)) MsgBox str_Left & vbCrLf & " " & "OKボタンを押してください!" Sheets("Sheet1").Range("A3").Select Dim se_r As String se_r = Application.InputBox("バーコードを入力してください") Select Case se_r Case "False" MsgBox "キャンセルされました" Case "" MsgBox "空欄が入力されました" Case Else Range("A3").Value = se_r End Select End Sub ' ///Sheet2/// Private Sub Worksheet_Activate() Dim Emp(1 To 300) As String Dim msg As String Dim i, i2, Cnt As Integer Dim N_In As Variant For i = 3 To 3 If IsEmpty(Cells(i, 1).Value) = False Then 'ここで空欄判定 Worksheets("Sheet1").Range("3:3").Insert '対象セルアドレスを改行処理 End If '(1)シートを変数にセット Dim ws1 As Worksheet Dim ws2 As Worksheet Dim st1, s, i3 As Long Dim Bst As Range Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") '(2)シートを指定してデータを転記 st1 = ws1.Cells(Rows.Count, "E").End(xlUp).Row 'A列の最終行を設定する s = 3 For i3 = 3 To st1 Set Bst = ws2.Columns("E").Find(What:=ws1.Cells(i3, "E"), LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) シート間のE列を比較 If Bst Is Nothing Then '比較して無い場合は、下記を実行 ws1.Cells(s, "A") = ws1.Cells(i3, "A") '追加する文字を転記する。（コード） s = s + 1 End If Next i3 Next i '(1)シートを変数にセット Dim ws1_ As Worksheet Set ws1_ = Worksheets("Sheet1") ws1_.Activate End Sub

  • VBAについて

    以下のプログラムは、1年間の価格合計を求めるプログラムです。 これを実行するとうまくいくこともありますが、エラーが起きることもあります。 どうやら下記コードが原因のようなのですが、間違いがわかりません。 Target.Offset(0, 1).Value = run * (13 - month) どこが間違っているのでしょうか。 また最終的に、A行かB行のどちらかが更新されたときにこのプログラムを 実行させたいのですが、方法がわかりません。 無知な質問ではありますが、どなたか教えてください。 --------------------------------------------------------- Private Sub Worksheet_Change(ByVal Target As Range) Dim month As Integer Dim run As Integer If Intersect(Target, Range("A25:A35")) Is Nothing Then Exit Sub Else If Target.Offset(0, -2).Value <> "" Then month = Target.Offset(0, -2).Value month = month - 3 If month = -2 Then month = 10 ElseIf month = -1 Then month = 11 ElseIf month = 0 Then month = 12 End If run = Target.Offset(0, 0).Value Target.Offset(0, 1).Value = run * (13 - month) End If End If End Sub

  • VB2005で、Structureの配列を返すプログラムを以下のように書きたい

    VB2005で、Structureの配列を返すプログラムを以下のように書きたいのですが、そもそもVB6しか使ったことが無いもので、以下のような素数の結果を返すこのプログラムの書き方はVB2005らしいでしょうか？ Module Module1 Public Structure SosuuStatus Public num As Integer Public status As String End Structure Class Sosuu Function SosuuCheck(ByVal st As Integer, ByVal ed As Integer) As SosuuStatus() Dim i As Integer, j As Integer Dim sosuu(0 To ed - st) As SosuuStatus Dim cnt As Integer = 0 For i = st To ed sosuu(cnt).num = i sosuu(cnt).status = "" '初期化 If 1 = i Then sosuu(cnt).status = "素数ではない" ElseIf 0 = (i Mod 2) Then sosuu(cnt).status = "素数ではない" Else For j = 3 To Math.Sqrt(ed) If 0 = (i / j) Then sosuu(cnt).status = "素数ではない" End If Next j End If If sosuu(cnt).status = "" Then sosuu(cnt).status = "素数である" End If cnt = cnt + 1 Next i SosuuCheck = sosuu End Function End Class End Module

  • VBAでWebクエリにて情報を自動収集するプログラム

    自動売買ロボット作成マニュアルという本を買いました。 これは株などを自動売買するプログラムを作るための方法が書いた本です。（言語はエクセルに搭載されてあるVBAというプログラム言語です） そのプログラムを作る過程で、まずYahoo!ファイナンスから株価などの情報を10年分自動収集するプログラムを作ったのですが、「インターネットサーバーに接続できません」と出て、きちんと実行できません。 そこで、デバックをすると.Refresh BackgroundQuery:=Falseというプログラムのところがチェックされました。どうしたらいいでしょうか？ この文章だけでは対処できないと思いますのでプログラムを書いておきます。長々とお読みいただきありがとうございます。どうかお知恵をお貸しください。 Dim url As String Dim lastrow As Integer Dim i As Integer Sub Get_Data() With ActiveSheet.QueryTables.Add(Connection:=url, Destination:=Cells(lastrow, 2)) .Name = _ "t?s=998407.o&a=4&b=22&c=2008&d=7&e=24&f=2008&g=d&q=t&y=0&z=998407.o&x=_1" .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .BackgroundQuery = True .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .WebSelectionType = xlSpecifiedTables .WebFormatting = xlWebFormattingNone .WebTables = "19" .WebPreFormattedTextToColumns = True .WebConsecutiveDelimitersAsOne = True .WebSingleBlockTextImport = False .WebDisableDateRecognition = False .WebDisableRedirections = False .Refresh BackgroundQuery:=False End With End Sub Sub Calc() Dim code As String Dim data_length As Integer, date_temp As Date Dim day_s As Integer, month_s As Integer, year_s As Integer Dim day_e As Integer, month_e As Integer, year_e As Integer Dim row_length As Integer code = "998407.o" data_length = -3650 date_temp = DateAdd("d", data_length, Now) day_e = Day(Now) month_e = Month(Now) year_e = Year(Now) day_s = Day(date_temp) month_s = Month(date_temp) year_s = Year(date_temp) Range("B4:H65000").ClearContents For i = 0 To Abs(data_length) * 0.65 Step 50 url = "URL; http://table.yahoo.co.jp/t?s=" & code & "&a=" & month_s & "&b=" & day_s & "&c=" & year_s & "&d=" & month_e & "&e=" & day_e & "&f=" & year_e & "&g=d&q=t&y=" & i & "&z=" & code & "&x=.csv" If i = 0 Then lastrow = "4" Call Get_Data If Range("B4") = "" Then Exit Sub End If Else lastrow = (Range("B4").End(xlDown).Row + 1) Call Get_Data Range("B" & lastrow, "H" & lastrow).Delete row_length = (Range("B4").End(xlDown).Row) If row_length - lastrow < 49 Then Exit For End If End If Next Range("B5:H65000").Sort Key1:=Columns("B") lastrow = Range("B4").End(xlDown).Row Range("B5", "B" & lastrow).NumberFormatLocal = "yyyy/mm/dd" Range("C5", "H" & lastrow).NumberFormatLocal = "0" Range("A1").Select End Sub

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

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

質問する