• 締切済み

複数シートに跨るcountifの結果を表示したい

再びEXCELマクロ関連の質問です。 とある商品の販売数をエクセルで管理しています。 商品は１０個でワンセットで、セットごとに別のシートで管理しています。 セット１をsheet2で管理し、１０個売り上げたらsheet３でまた次の１０個を管理する…といった方法です。（この時点で無駄だと思いますが、この書式は崩せない前提で質問させてください） G列に売り上げた”年月”が記載されていて、集計したい”年月”を入力して計算を開始すると、ブックにあるシートの数だけ同じ計算をして、トータルと売上数をカウント、その結果をsheet1の集計表に反映させる、ということをしたいです。 （2019年10月の売り上げが２つ、３つのシートにまたがっている可能性があるのでこのような方法をとっています） シートのインデックス番号を変数iとして、仮にシート２～３までの売り上げ個数をカウントするとき、以下のマクロではシート２の結果しか表示できませんでした。 各iの変数で計算したcntを合計する計算式を記載しないといけないのはわかるのですが、その方法がわからず……みなさんのお知恵をお貸しください。 Sub 販売数() Dim cnt As Variant Dim FoundCell As Variant Dim sMonth As Variant Dim sh As Worksheet Dim i As Variant sMonth = Application.InputBox("集計したい年月を入力してください（例：2019年4月⇒201904）") For i = 2 To 3 Set sh = Worksheets(i) cnt = WorksheetFunction.CountIf(sh.Range("G4:G43"), sMonth) Next Set FoundCell = Cells.Find(What:=sMonth, LookIn:=xlValues) If FoundCell Is Nothing Then MsgBox "一致なし" Exit Sub Else FoundCell.Offset(0, -4).Value = cnt End If End Sub

みんなの回答

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

ながながと質問を書いているが、何を問題にしているかわからんが、同じブック内の複数シートを１つずつカウント対象にするなら Sub test01() x = 0 For Each sh In Worksheets x = x + Application.WorksheetFunction.CountIf(sh.Range("A:A"), "横田") Next MsgBox x End Sub ーー 内容は、各シートのA列で、値が「横田」のセルを数えた。 シートの中に除外するシートが１が，２つあっても（結果を出すシートなど） 修正はIF文を使って除外しさえすれば仕舞。 探す範囲が、各シートでバラバラの場合は工夫を問うするが。

  • kkkkkm
  • ベストアンサー率65% (1623/2463)
回答No.1

cnt = WorksheetFunction.CountIf(sh.Range("G4:G43"), sMonth) は cnt = cnt+WorksheetFunction.CountIf(sh.Range("G4:G43"), sMonth) じゃないでしょうか。

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

関連するQ&A

  • エクセル　複数シート(　VLOOKUP　ユーザー定義関数

    複数シート(範囲）を指定できるVLOOKUP関数をユーザー定義で作りたいと思ってます。下記のコードではうまく動かないので教えてください。 Function VLOOKUPM(検索値 As Variant, 対象シート As String, 対象セル As Range, 列番号 As Integer) As Variant Dim i As Integer Dim r As Range Dim sh As Variant Application.Volatile sh = Split(対象シート, ",") For i = 0 To UBound(sh) Set r = Sheets(sh(i)).Range(対象セル) If 検索値 = r Then VLOOKUPM = r.Offset(0, 列番号) Exit Function End If Next End Function

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

    ユーザー定義関数を作りました。 ところが、この関数が自動再計算をしてくれません。 どうしたら自動再計算するようになるのでしょうか？ よろしくお願いします。 ちなにこの関数は、自分のシートの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

  • 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回同じカラー番号を書いたのですがこちらも良かったら手直し方法を教えていただければ助かります。 宜しくお願いします。

  • 同じシート名を一枚にまとめる

    エクセルのマクロでファイル内の同じシート名を一枚にまとめたい。 シート名が"売上"、"売上（2）"、"売上（3）"・・・ のようになっていて、売上シートの枚数は変動します。 他にも、、"部署"、"部署（2）"、"部署（3）"・・・・ のようにシート枚数が変動します。 売上、部署シートの1行目はタイトル行になっています。 そして、ＢＯＯＫ内には、他にもシートがいくつかあります。 ＢＯＯＫ内の "売上"シート名を一枚にまとめ、 "部署"シート名を一枚にまとめる方法をどうかご教授願います。 複数のＢＯＯＫから一つのファイルにまとめる事が出来たのですが、 どうやっても、同じシート名同士だけをまとめるマクロが出来ず、 とても困っています。 どうか、助けて頂けないでしょうか？ 何卒お願い致します。 ちなみに、 下記は途中で断念した案の一つです。 統合表シートを売上シートが隣に並ばないといけないのと、 売上、売上（2）も隣に並ばないと動かないのと 部署（2）、部署（3）・・・もまとめてしまうから、 駄目でした。 とりあえず、売上だけはまとめようとしました。 下記のコードには、こだわりませんので、助けてください。 お願いします。 Sub まとめ() Dim sh1 As Worksheet Dim sh2 As Worksheet Dim j As String Dim d As String Dim i As Integer Set sh1 = Worksheets("統合表") j = 2 '統合表のデータ書きこみ開始行 For Each sh2 In ActiveWorkbook.Worksheets If sh2.Name = "発注" Or _ sh2.Name = "部署" Or _ sh2.Name = "使い方" Or _ sh2.Name = "残すシート" Then Exit For '統合表は統合対象外 d = sh2.Range("A65536").End(xlUp).Row '各シートの最終行を知る ' MsgBox d For i = 2 To d sh1.Cells(j, "A") = sh2.Cells(i, "A") sh1.Cells(j, "B") = sh2.Cells(i, "B") j = j + 1 Next i Next End Sub

  • VBAのcountif

    ここで質問させていただき、配列に必要なデータを入力する所までは出来ました。 次に各行ごとの"OK"の数をカウントしたいのですが、どのように記述すればよいのでしょうか？ Sub count0(a, b, c, d, e) 　Dim i1 As Long 　Dim i2 As Long 　Dim A1 As String 　Dim bb As Variant 　Dim cc As Variant 　Dim dd As Variant 　Dim ee As Variant 　Dim myLastRow As Long 　Sheets(a).Select 　myLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1 　bb = Range(b).Resize(myLastRow, 6) 　cc = Range(c).Resize(myLastRow, 6) 　dd = Range(d).Resize(myLastRow, 6) 　ee = Range(e).Resize(myLastRow) 　For i1 = 1 To myLastRow 　　For i2 = 1 To 6 　　　If bb(i1, i2) = "" Then 　　　　　A1 = "NG" 　　　　ElseIf bb(i1, i2) = "A1" Or cc(i1, i2) = "A1" Then 　　　　　A1 = "-" 　　　　ElseIf bb(i1, i2) = cc(i1, i2) Then 　　　　　A1 = "OK" 　　　　Else 　　　　　A1 = "NG" 　　　End If 　　　dd(i1, i2) = A1 　　Next i2 '配列をカウントするこの行以降の記述が良く分かりません。 　　ee(i1) = Application.WorksheetFunction.CountIf(dd(), "OK") 　Next i1 　Range(e).Resize(myLastRow) = ee End Sub

  • ExcelVBAの転記（1つのひな形へ複数シート）

    お世話になります。ExcelVBAを少し学んだ程度の者です。 1つのExcelファイルに複数存在する個別のシートから、1つのひな形シートへ転記する方法に頭を悩ませております。イメージとしては名簿管理のようなものとご理解してください。 複数存在するシート（約200シート）には、項目名に対するデータ（例えば、名前や住所などが定められたセルに入力されています）が揃っておりますが、書式の変更によりひな形のシートへ転記する必要があります。 200ほどのシートには、M10セルには名前が、B15セルには住所、C16セルには電話番号が……という具合に入力されています。これらのデータをひな形シートでは、N5セルに名前、C13セルに住所、D14セルには電話番号などを転記する必要があります（セル番地は適当です）。 ひな形シートは1枚で、マクロを実行する際にひな形シートをコピーして（Xとします）、200ほどの個別のシート（A、B、C……）を転記しようと思っております。A、B、C……に入力された複数の値は項目別にCells(i,j).Valueを、XへCells(x,y).Valueへ転記すれば良いと考えておりましたが、上手くいきません。ひな形をコピーしたXのシートへ上手く転記ができず、Aを転記したシートばかりが量産され、B、C以降のシートへ制御が移っていないようです。恐らく、Workwsheetオブジェクトのカウンタ変数に問題があると思われます。 VBAのコードとしては下記のように記述しております。 Sub SheetCopy() Application.ScreenUpdating = False Dim cnt As Long 'シート数カウント変数 Dim i As Long 'シート用のカウンタ変数 Dim wb As Workbook 'コピー元 Dim ws1 As Worksheet 'コピー元 Dim ws2 As Worksheet 'コピー先 '1がコピー元で2がコピー先 cnt = Worksheets.Count 'シート数をカウント i = 2 Set wb = Workbooks("転記用.xlsm") Set ws1 = wb.Worksheets(i) Set ws2 = wb.Worksheets("ひな形") For i = 1 To cnt ws2.Copy after:=Worksheets(i) Set ws2 = wb.Worksheets(i) ws2.Cells(2, 2).Value = ws1.Cells(2, 13).Value '名前 ws2.Cells(3, 2).Value = ws1.Cells(6, 10).Value '住所 以下、同様の転記処理を記述しています。 Next i End Sub 上記のコードを、パッと見たところ、コピーはしているものの、転記先がコピー元になっているのも原因だと思います（コピー先へ転記する方法が現時点でわかりかねます……ここがネックだと考えております）。 ご知見のある方々から、アドバイスをいただけると幸いです。 どうぞ、よろしくお願い申し上げます。

  • VBAで複数ファイルのページ数出力

    Win10のOffice365のExcelを使用しています。 GetOpenFilenameで選択した複数のExcelファイルのファイル名＋印刷ページ数を マクロを実行したファイルに出力するというマクロを作成しました。 マクロを実行する度に既存データがあれば追加されていくようにしたいのですが、上手くいきません。 それどころか、実行時も複数ファイル選択したにも関わらず、 １ファイルのデータしか出力されない状態です。 実行後のイメージは添付ファイルの通りです。 （A1、A2はデフォルトで入力しています。） 勉強を始めたばかりなので改善点もあれば、教えて頂きたいです。 よろしくお願い致します。 ================================================= Option Explicit Sub pagecount() Dim Page As Long, cnt As Long, xlcnt As Long Dim fs As Variant, path As Variant Dim Fname As String Dim i As Integer Dim wb1 As Workbook, wb2 As Workbook Dim sh As Worksheet With CreateObject("WScript.Shell") .CurrentDirectory = ThisWorkbook.path End With fs = Application.GetOpenFilename(filefilter:="Microsoft Excelブック,*.xls*", MultiSelect:=True) If IsArray(fs) Then For Each path In fs Set wb1 = Workbooks.Open(path, , True) Set wb2 = ThisWorkbook Do Until (Fname = "") Page = 0 For Each sh In wb1.Worksheets Page = Page + sh.PageSetup.Pages.Count Next sh xlcnt = Cells(Rows.Count, 1).Row cnt = Cells(xlcnt, 1).End(xlUp).Row If wb2.ActiveSheet.Cells(cnt, 1).Value <> "" Then wb2.ActiveSheet.Cells(cnt, 1).Value = Fname wb2.ActiveSheet.Cells(cnt, 1).Offset(0, 1) = Page wb1.Close savechanges:=False Fname = Dir() cnt = cnt + 1 End If Loop Next path End If End Sub

  • VBAで複数Excelの複数条件を満たすもの抽出

    2つのExcelファイル("1月顧客別商品別.xls"と"顧客別管理.xlsx")において、顧客コードと商品コードの双方が一致しているものの売上高と粗利を顧客別管理.xlsxの対応欄(商品別になっている)(1月の売上高の入力欄：K9～K32、粗利の入力欄：K39～62)に入力させるVBAを作りたく、以下のコードを書いたのですが、コードが恐らくハチャメチャのため重たすぎて正しく動作しているかどうかわかりません。 大量のデータがあるためDictionaryを使用したものの、どん詰まりすぎてもう何もわかりません… 間違っているなら修正ポイントを、正しいなら軽量化する方法を教えていただけると大変助かります。 なお、前提条件として、 "1月顧客別商品別.xls"：”集計”シートのA~E列に”顧客コード”、”顧客名”、”商品コード”、”売上高”、”粗利”が２行目以降並んでいます。 "顧客別管理.xlsx"：左から4枚目～最後から数えて3ページ目までのシートがそれぞれ顧客別のシートで、それぞれシート名が顧客コードになっていて、B列に売上高の商品一覧(B9～B32)・粗利の商品一覧(B39～B62)が並んでおり、検索しやすくなるためにそれぞれ対応する行のA列に商品コードを入力してあります。 ----------------------------------------------------------------------------------------- Sub 最終集計シートと月次実績シートの顧客名項目名一致入力() Dim nws As Worksheet, mws As Worksheet, ynws As Worksheet, ydws As Worksheet Dim mdwb As Workbook, ydwb As Workbook Dim i Dim Dic As Object Dim dkey As Variant, data As Variant Dim dtRow As Integer Dim opRow As Long Set mdwb = Workbooks("1月顧客別商品別.xls") Set ydwb = Workbooks("顧客別管理.xlsx") Set mws = mdwb.Worksheets("集計") Set Dic = CreateObject("Scripting.Dictionary") mdwb.Activate mws.Activate dtRow = Cells(Rows.Count, 1).End(xlUp).Row dtRow = 2 '月次実績データ行設定 'C列をDictionaryオブジェクトに格納 Do Until mws.Cells(dtRow, 3).Value = "" dkey = mws.Cells(dtRow, 3).Value data = Array(mws.Cells(dtRow, 4), mws.Cells(dtRow, 5)) If Not Dic.exists(dkey) Then Dic.Add dkey, Null End If dtRow = dtRow + 1 Loop ydwb.Activate For i = 4 To ydwb.Worksheets.Count - 2 Set ydws = ydwb.Worksheets(i) ydws.Activate opRow = 9 Do Until ydws.Cells(opRow, 1).Value = 32 dkey = ydws.Cells(opRow, 1).Value If Dic.exists(dkey) And mws.Cells(dtRow, 1) = ydws.Name Then ydws.Cells(opRow, 11).Value = data(0) ydws.Cells(opRow + 30, 11).Value = data(1) End If Loop Next i End Sub

  • 他のブックの複数シートの〇記号の串刺し

    エクセルで次のような表のデータが１ヶ月分、31日分あり ます。すなわち31枚のシートに同じ表で中の○× の内容が違うデータがあります。〇×は単純に「まる」「ばつ」と入力して変換したものです。 　 ア イ ウ エ オ (1) 〇 × × 〇 〇 (2) 〇 × 〇 〇 × (3) × 〇 〇 〇 × (4) 〇 〇 × × 〇 そして〇をゼロ、×を1と数えて、 31枚のシートの〇と×を集計して他のブックの 同じ表に集計の結果を示したい のです。 例えばこんな感じで他のブックのシート の同一の表に計算結果を表示したいです。 ア イ ウ エ オ (1) ７ ４ ５ ０ ０ (2) ８ ５ ０ ２ ２ (3) １ １ ０ １ ０ (4) ０ ０ ４ ６ ８ 31枚のシートの〇と×を数値に 変換し、それを串刺し集計した いのです。 countifは串刺し集計 で使えないので 次のようなユーザ定義関数を教えて戴き、同じブックの３２枚目のシートの同じ表に 集計が可能となり誠に教えて戴いた方には感謝する次第では御座いますが、 他のブックの同一の表に集計するには、ユーザ定義関数の記述をどのようにすれば よろしいでしょうか。宜しくお願い致します。 Public Function CountIfAcross(シート区間先頭セル As Range, シート区間後尾セル As Range, 検索条件 As String) Dim sRef As String, sRefE As String, c As Range, cnt As Long, i As Long 　　sRef = シート区間先頭セル.Address(0, 0) 　　sRefE = シート区間後尾セル.Address(0, 0) 　　If sRefE <> sRef Then sRef = sRef & ":" & sRefE 　　For i = シート区間先頭セル.Worksheet.Index To シート区間後尾セル.Worksheet.Index 　　　　For Each c In Sheets(i).Range(sRef) 　　　　　　If c.Text Like 検索条件 Then cnt = cnt + 1 　　　　Next 　　Next i 　　CountIfAcross = cnt End Function 普通のExcel関数のように、 =CountIfAcross(Sheet1!B2,Sheet31!B2,"×") =CountIfAcross('#1'!B2,'#31'!B2,"×") 等の様に シート区間先頭セル、シート区間後尾セル、検索条件 を指定してカウントした数を返します。

  • VBA 複数のシートをまたいでの連想配列

    win7、Excelは2013を使用しています。 添付画像の様に、12シートの合計を連想配列に格納しsheet13に書き出したいのですが、プロシージャーの下から6行目のところで、エラーコード451が出ます。 どの様に変更すれば良いか教えて下さい。 Sub 年間集計() Dim Dic Dim i As Integer Dim j As Integer Dim sh As Worksheet Dim rng As Range Dim buf As String Dim num As Integer Set Dic = CreateObject("Scripting.Dictionary") For Each sh In Worksheets For Each rng In sh.Range("J2", sh.Cells(Rows.Count, 10).End(xlUp)) buf = rng.Value num = rng.Offset(, 1).Value If Not Dic.Exists(buf) Then Dic.Add buf, num Else Dic.Item(buf) = Dic.Item(buf) + num End If Next rng Next sh j = 2 With Worksheets("Sheet13") For i = 0 To Dic.Count - 1 .Cells(j, 1) = Dic.Keys(i)　　　’エラー箇所 .Cells(j, 2) = Dic.Items(i) j = j + 1 Next i End With End Sub

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

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

質問する