• ベストアンサー

VBA エクセル 合計

皆様、こんにちは。 それぞれの値が入っている会計シート(シートの形式は同じ)を一つの合計シートに合計しようとしていますが、うまくいきません。具体的に、数値の合計ができません。 例えば、ある項目に対して、シートAに100が入力され、シートBには230が入力されているとすれば、合計シートに100+230=330を入力したいです。なお、全ての会計シートは"Form"というエクセルシートにあり、その数をユーザが決めますので、検索しなければいけません。そして、合計シートは"Result"にあります。 以下のように書いてみましたが、間違っているようです。 Worksheets("Result").Activate Dim SR As Integer Dim SC As Integer 'SR is start row 'SC is start column SR = 6 SC = 2 Worksheets("Form").Activate Dim i As Integer i = 68 Do While 1 = 1 If Selection.Cells(i, 4).Value = "" Then Exit Do End If i = i + 49 Loop Sum = 0 Sum = Sum + Selection.Cells(i, 4) Worksheets("Result").Activate Cells(SR + 5, SC + 2) = Sum 詳しい方に教えていただければ非常に助かります。 どうぞよろしくお願いします。

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

  • ベストアンサー
  • Wendy02
  • ベストアンサー率57% (3570/6232)
回答No.2

こんにちは。 質問文だけでは良く分かりませんが、コードは分かりにくいです。なるべく文章で詳しく書いていただいたほうがよいです。 '------------------------------------------- Sub Test2()   Dim nR As Long   Dim nC As Long   Dim i As Long   Dim dSum As Double      nR = 6 'nR is start row number   nC = 2 'nC is start column number 'the Valuable of SR is out of inexplicit rules.   nR = nR +5   nC = nC +2   i = 68   With Worksheets("Form")     Do       If .Cells(i, 4).Value <> "" Then         dSum = .Cells(i, 4).Value       Else         Exit Do       End If       i = i + 49     Loop   End With      Worksheets("Result").Cells(nR, nC).Value = dSum End Sub Sum は、関数名ですから、出来れば、d =Double のdSum と変えたように良いと思います。

lyu05665
質問者

お礼

mt2008様、Wendy02様、ありがとうございました。 お蔭様で、コードにあった問題点を見つける事ができ、今はちゃんと動いています。 本当にありがとうございました。

その他の回答 (1)

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

やりたい事が具体的になっていないので、思い違いをしているかも知れませんが、要するにこういうことでしょうか? 「Form」シートのD68から49行毎(D68、D117、D166……)のセルを見て行き、空白が現れるまでの値の合計を「Result」シートD11に表示したい。 で、あれば以下の様になります、提示されたソースをなるべくそのまま使用しています。元のソースとの違いを見てください。 Sub test() Dim SR As Integer Dim SC As Integer 'SR is start row 'SC is start column SR = 6 SC = 2 Worksheets("Form").Activate Dim i As Integer i = 68 Sum = 0 Do While 1 = 1  If Cells(i, 4).Value = "" Then   Exit Do  End If  Sum = Sum + Selection.Cells(i, 4)  i = i + 49 Loop Worksheets("Result").Activate Cells(SR + 5, SC + 2) = Sum End Sub また、Fromシート中のセル範囲のことを「会計シート」と呼んでいるようですが、Excelのシートと紛らわしく混乱の元です。

関連するQ&A

  • Excel VBAで検索する

    Excel VBAで、Sheet1に貼り付けたテキスト内から Sheet2に記載した(1列ごとの)キーワードを検索し キーワードが含まれている行をSheet3に貼り付ける処理をしているのですが、始めたばかりなので上手くいきません。 下記がソースです。 Dim moji As String Dim word As String Dim result As Integer For i = 3 To 103 For j = 2 To 21 moji = ThisWorkbook.Worksheets("Sheet1").Cells (i, 1).Value word = ThisWorkbook.Worksheets("Sheet2").Cells (j, 2).Value result = InStr(moji, word) If doResult <> 0 Then For k = 1 To 100 ThisWorkbook.Worksheets("Sheet3").Cells (k, 1).Value= moji Next k End If Next j Next i このソースでは上手くいかないのですが、どこがダメなのか分からないので、解決の糸口がつかめません。 アドバイスなどお願いします。

  • 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

  • VBAを使った九九、及び合計、平均の表の作り方

    Visual Basic初心者です。 Excel 2003を使って、九九表を表示させるプロジェクトを作りたいのですが、どうしても途中で詰まってしまい、九九だけどころか、合計と平均すら表示させることができない状態です。 私の途中まで組んだタグは以下の通りです。どなたかよろしくお願いします。 Private Sub CommandButton1_Click() Call Kuku End Sub Option Explicit Dim Sum(20) As Double Sub Kuku() Dim i As Double, j As Double, num As Integer num = InputBox("numの値を入力しなさい") Sheets("Date").Cells.Clear For i = 1 To num Sheets("Date").Cells(1, i + 1) = i Sheets("Date").Cells(1 + i, 1) = i Sum(i) = 0# For j = 1 To num Sheets("Date").Cells(i + 1, j + 1).Value = Sum(i) Sum(i) = i * j Next j Next i Call Heikin Call Hyoudai MsgBox ("処理が終了しました") Sheets("Date").Select End Sub Sub Heikin() Dim i As Double, num As Integer, n As Integer For i = 9 To num Sheets("Date").Cells(i + 1, n + 2).Value = Sum(i) Sheets("Date").Cells(i + 2, n + 1).Value = Sum(i) Next i End Sub Sub Hyoudai() Sheets("Date").Cells(1, 1) = "九九" Sheets("Date").Cells(1, 11) = "合計" Sheets("Date").Cells(1, 12) = "平均" End Sub

  • Excel VBA 答えが0になってしまうのですがどうしたらなおりますか?

    こんばんはB列に上からいくつか数字が入力されているとします。 そのB列の最下行にSUM関数を入力させるマクロを作成しましたが、 なぜか計算結果が0になってしまいます。 循環になってしまっていたので反復計算にチェックをいれ、再計算させましたが思ったような答えが出ませんでした。 この計算結果が0になってしまう現象はどうやっって回避したらよいのでしょうか。合計欄をC列に変えると正常になりますが、B列に計算式を入力させると0になってしまうのは、どうしてなのでしょうか。 下記のコードが悪いのでしょうか?宜しくお願い致します。 (※通常にExcel2003を使用して、単純にセルどうしの引き算をしていても答えが0になってしまう場合があります。これも同じ循環なのかも知れませんので、回避方法を教えてください。) Sub SUM関数を入力する() Dim r As Integer '最下行 Dim m As Integer '対象列 Dim a As Variant Dim siki As Variant Worksheets(3).Activate r = Worksheets(3).Range("B65536").End(xlUp).Row + 1 Range("B" & Format(r)).Select m = 2 'R1C1方式で選択 a = "R" & 2 & "C" & 2 & ":R" & r & "C" & 2 siki = "=sum(" & a & ")" Range(Cells(r, m), Cells(r, m)).FormulaR1C1 = siki End Sub

  • エクセル2019 VBAについて

    エクセル2019でVBAを使いコピーペーストの勉強中です、次の箇所(Dim i As integr)で、ユーザー定義型は定義されていませんと指摘されて止まってしまします、Sheet("データ")には3行のデータは入っています、VBA初心者のため、この後が、なかなか前に進めません、どうかよろしくおねがいします。 ********************************** Sub 練習() Dim s1 As Worksheet: Set s1 = Worksheets("請求書") Dim s2 As Worksheet: Set s2 = Worksheets("データ") Dim r1 As Integer: r1 = 18 Dim r2 As Integer: r2 = 2 { Dim i As integr } For i = 0 To 2 s1.Range(s1.Cells(r1 + i, 1), s1.Cells(r1 + i, 3)).Value = s2.Range(s2.Cells(r2 + i, 2), s2.Cells(r2 + i, 4)).Value s1.Cells(r1 + i, 4).Value = s1.sells(r1 + i, 2).Value * s1.Cells(r1 + i, 3).Value Next End Sub ***************************************

  • ExcelのVBAの配列に関する質問です。

    ExcelのVBAの配列に関する質問です。 sheet1のデータをsheet2に表示するVBAを作成しています。。 sheet1のデータは7行目からスタートし、sheet2のデータは26行目からスタートしています。。 sheet1とsheet2の列は同じ並びではないため、それぞれのシートの列番号をCellsを用いて指定しています。 Sub test1() Dim endrow As Long endrow = Worksheets("sheet1").Range("A65536").End(xlUp).Row Dim i As Long Dim j As Long For i = 7 To endrow j = i + 19 Worksheets("sheet2").Cells(j, 1) = Worksheets("sheet1").Cells(i, 2) Worksheets("sheet2").Cells(j, 8) = Worksheets("sheet1").Cells(i, 28) Worksheets("sheet2").Cells(j, 9) = Worksheets("sheet1").Cells(i, 31) Worksheets("sheet2").Cells(j, 10) = Worksheets("sheet1").Cells(i, 32) ・ ・ ・ ※長いので省略 Next i End Sub 上記のtest1は正常に動くのですが、データ量が多いため、処理に時間がかかってしまいます。 高速化できないかと、以下のように変更しました。 Sub test2() Dim dataRange1 As Variant Dim dataRange2 As Variant dataRange1 = Worksheets("sheet1").Range("A1:GI10006") dataRange2 = Worksheets("sheet2").Range("A1:DZ10018") Dim endrow As Long endrow = Worksheets("sheet1").Range("A65536").End(xlUp).Row Dim i As Long Dim j As Long For i = 7 To endrow j = i + 19 dataRange2(j, 1) = dataRange1(i, 2) dataRange2(j, 8) = dataRange1(i, 28) dataRange2(j, 9) = dataRange1(i, 31) dataRange2(j, 10) = dataRange1(i, 32) ・ ・ ・ ※長いので省略 Next i End Sub test2は、エラーメッセージ等は表示されませんが、sheet2にデータが表示されません。 ちなみに、以下のようにsheet1のみ配列化した場合は、正常に表示されました。 Worksheets("sheet2").Cells(j, 1) = dataRange1(i, 2) Worksheets("sheet2").Cells(j, 8) = dataRange1(i, 28) Worksheets("sheet2").Cells(j, 9) = dataRange1(i, 31) Worksheets("sheet2").Cells(j, 10) = dataRange1(i, 32) test2は、どこが間違っているのでしょうか? ご教示ください。 よろしくお願いいたします。

  • Excel vba selectが効かない

    2と3の2つのエクセルファイルがあります。縦の列を新しいファイルの横の行に コピーしていきたいプログラムです。 2のファイルの1シート目の"C8:C25" 3のファイルの1シート目の"C9:C65" を新しい1のファイルの1シート目の1行目にコピーするプログラムを 作っていますが1シート目はpasteされるのですが 3のファイル2シート目からselectの指定が"C9:C65"ではなく、B9からQ65の指定になってしまい思ったコピーができません(★のところ)、1シート目はうまくいっているのでどうして3のファイルの2シート目のからうまくいかないかわかりません。 5シートまででテストをしているのですが実際は各々255シートありもってくる列も 12列あります。とりあえずCの列だけ5シートで試してみています。 Dim i As Long Dim N As Long i = 1 N = 1 Do While i <= 5 ''C列''' Workbooks(2).Worksheets(i).Activate   '2のファイル Worksheets(i).Range("C8:C25").Select   'もってくるところ Selection.Copy Workbooks(1).Worksheets(1).Activate   '1新しいファイル Range("C" & N).Select   '貼り付けるところ Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True Workbooks(3).Worksheets(i).Activate   '3のファイル Workbooks(3).Worksheets(i).Range("C9:C65").Select  '★もってくるところ Selection.Copy Workbooks(1).Worksheets(1).Activate   '1新しいファイル Range("U" & N).Select   '貼り付けるところ Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=True i=i+1 N=N+1 LOOP

  • ExcelのVBAについて質問です。Excelは2003です。

    ExcelのVBAについて質問です。Excelは2003です。 コマンドボタン1で下記のプログラムを実行するようにしています。 Sub Macro1() ' ' Macro1 Macro ' ' Dim iRows As Integer Dim sRows As String Dim i As Integer For i = 1 To 100 Application.Wait Now + TimeValue("00:00:05") ' 最終行の調査: iRows = Worksheets("Sheet1").UsedRange.Rows.Count ' 最終行をシート3にコピー Worksheets("Sheet1").Rows(iRows).Copy Destination:=Worksheets("Sheet4").Range("1:1") ' CH1 の最新データをシート3にコピー Worksheets("Sheet3").Range("B9").Value = Worksheets("Sheet1").Cells(iRows, 3).Value ' CH2 の最新データをシート3にコピー Worksheets("Sheet3").Range("C9").Value = Worksheets("Sheet1").Cells(iRows, 4).Value Next i End Sub これをコマンドボタン2で途中でも強制的に終了するようにしたいのですがコマンドボタン2にはどのようなプログラムを入れればいいでしょうか?

  • VBA 切り分けがうまくいかない

    A列のデータで切り分けるようプログラム作成しています。 あるデータをA列で切り分けることができましたが、切り分けた後のファイル内容を確認したら、E列以降の内容が元データと異なっていました。 E列にはプルダウンメニューを入れていますので、それが原因かと思い、プルダウンメニューを消した元データで切り分けてみましたが、解決できませんでした。 他のデータ(プルダウンなし・空欄なし)では問題なく正しい内容で切り分けることができています。 フルダウン入りや空欄があるデータだと、正確に切り分けることができないかどうかご教示いただけますと幸いです。 VBAを作った担当者は異動してしまったため、直すことができませんでした。 宜しくお願いします。 Sub Macro5() ' ' Macro5 Macro ' Dim txtFilename As String '元のファイル名 Dim txtS As String '分類名保存用 Dim htxtS As String '定形文保存用 Dim cRow As Integer '行数カウント用 Dim sRow As Integer '行数保存用 Dim eRow As Integer '最終行格納用 Dim h As Integer 'データ入力行保管用 Dim j As Integer 'データ入力開始列 Dim i As Integer '分類項目列保管用 Dim e As Integer '分類項目最終行数保管 i = Cells(18, 9).Value '分類項目列取得 j = Cells(14, 9).Value 'データ入力開始列 h = Cells(14, 11).Value 'データ入力行取得 htxtS = Cells(21, 9).Value '定型文取得 '元ファイル名(=同じフォルダ)を取得する txtFilename = Dir(ThisWorkbook.Path & "¥*.xlsx") 'ファイルを開ける Workbooks.Open ThisWorkbook.Path & "¥" & txtFilename Sheets(1).Activate '分類項目の最終行を取得する e = Cells(h, i).End(xlDown).Row '分類項目でソートを掛ける Cells(h - 1, j).Activate Range(Selection, Selection.End(xlToRight)).Select Range(Selection, Selection.End(xlDown)).Select Selection.AutoFilter ActiveWorkbook.Worksheets(1).AutoFilter.Sort.SortFields.Clear ActiveWorkbook.Worksheets(1).AutoFilter.Sort.SortFields.Add Key:= _ Range(Cells(h - 1, i), Cells(e, i)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _ :=xlSortNormal With ActiveWorkbook.Worksheets(1).AutoFilter.Sort .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With sRow = 0 cRow = h eRow = h '対象項目の行が無くなるまで繰り返す Do Until cRow > eRow '対象シートを新しいブックに貼り付ける Worksheets.Select Worksheets.Copy Sheets(1).Activate ' 項目名(=ファイル名)の退避 Cells(h, i).Select txtS = ActiveCell.Value '1つ目の分類項目を格納 ' 最終行の取得 eRow = Cells(h - 1, i).End(xlDown).Row cRow = h '分類項目が変わるまで繰り返す Do While txtS = Cells(cRow, i).Value cRow = cRow + 1 '1行加算 Loop '最終行が1行の時は削除されないように対象分類項目以下を削除をスキップする If cRow <> eRow + 1 Then '対象分類項目以下を削除 Rows(cRow & ":" & eRow).Select Selection.Delete End If '対象分類の行数を保存 sRow = cRow - 1 'ファイル名を指定して保存 Cells(1, 1).Activate Selection.AutoFilter With ActiveWorkbook .SaveAs ThisWorkbook.Path & "¥" & htxtS & txtS & ".xlsx" '元ファイルと同フォルダに保存する .Close End With '元のファイルに戻りファイル作成済みの項目を削除 Windows(txtFilename).Activate Sheets(1).Activate ActiveWindow.SelectedSheets(1).Select Rows(h & ":" & sRow).Select Selection.Delete Shift:=xlUp Cells(1.1).Activate Loop MsgBox ("ファイル分割処理が終了しました") '元ファイルを保存せずに閉じる Workbooks(txtFilename).Close SaveChanges:=False End Sub

  • エクセルVBAの二重ループについて

    今月VBAを勉強し始めた初心者です。 Webにて入力されたcsvファイルを編集する際に 最新投稿を残して表に出力する目的で 下記のマクロを作成して実行してみたところ 変数i、jが0になるまでループが繰り返されてエラーになってしまいます。 ループ範囲指定のどこに問題があるのでしょうか? こちら側の環境が OS:Windows7 64bit Ultimate Office2007 です。 ご教授宜しくお願い致します。 Sub namaesakujo() Dim i As Integer Dim j As Integer Dim mct As Integer Dim Name1 As String Dim Name2 As String Dim Time1 As Long Dim Time2 As Long Worksheets("result").Activate mct = Worksheets("result").UsedRange.Rows.Count '最大行数を指定 Name1 = Cells(i, 2).Value '名前1 Name2 = Cells(j, 2).Value '名前2 Time1 = Cells(i, 1).Value '時間1 Time2 = Cells(j, 1).Value '時間2 '変数iを最終行数~2行目まで指定 i = mct Do While i > 2 '変数jを最終行数~2行目まで指定 j = mct Do While j > 2 '2列目iと2列目jが等しい(名前が同じ)場合、日時が小さい方を削除する If Name1 = Name2 And Time1 > Time2 Then Cells(j, 1).EntireRow.Delete End If j = j - 1 Loop i = i - 1 Loop MsgBox "更新完了" End Sub

専門家に質問してみよう