- 締切済み
エクセルの複数条件抽出
エクセルで複数条件のカウントをしようと思い、下のマクロを作成しました。 うまくカウントができないのですが、どこらへんが間違っていますでしょうか？ （実際にはもっと多くのデータで利用を予定しており、小さいものでテストしています） よろしくお願いします。 Dim c1 As String Dim c2 As String Dim ans As Long Dim ws As Worksheet Dim b As Long, a As Long Set ws = Worksheets("date") For b = 2 To 4 For a = 3 To 5 c1 = Cells(a, 1).Value c2 = Cells(2, b).Value With ws.Range("B2:C7") ans = Evaluate("sumproduct((" & .Columns("c").Address & "=""" & c1 & """)*(" & .Columns("B").Address & "=""" & c2 & """))") Worksheets("a").Cells(a, b).Value = ans End With Next a Next b End Sub
- morinokumamaku
- お礼率33% (1/3)
- オフィス系ソフト
- 回答数1
- ありがとう数1
- みんなの回答 （1）
- 専門家の回答
みんなの回答
- KURUMITO
- ベストアンサー率42% (1835/4283)
ansの式はsumproduct関数を使っていますがせっかくマクロを組んでおらっるのですからこのような関数は使う必要もないでしょう。うまく機能していないようですね。 例えば次のようなマクロにすればよいでしょう。 Set ws = Worksheets("date") For b = 2 To 4 For a = 3 To 5 c1 = Cells(a, 1).Value c2 = Cells(2, b).Value n = 0 For i = 2 To 7 If ws.Cells(i, "B") = c2 And ws.Cells(i, "C") = c1 Then n = n + 1 End If Next i Worksheets("a").Cells(a, b) = n Next a Next b
関連するQ&A
- エクセルVBAについて
前回質問させていただきました件の追加機能になります。以前質問させていただきましたマクロが下記のものです。 Sub TESTa() Dim A As Long Dim B As Long Dim C As Long Dim D As Long Dim E As Long Dim F As Long '表の行数を調べる A = Worksheets("sheet1").Range("C65536").End(xlUp).Row - 1 For C = 1 To A For B = 4 To 7 'Sheet1のデータをSheet2に複写する Worksheets("Sheet2").Cells(B - 3 + D, 15) = Worksheets("Sheet1").Cells(C + 1, 1) Worksheets("Sheet2").Cells(B - 3 + D, 6) = Worksheets("Sheet1").Cells(C + 1, B) Worksheets("Sheet2").Cells(B - 3 + D, 14) = Worksheets("Sheet1").Cells(C + 1, 3) Worksheets("Sheet2").Cells(B - 3 + D, 10) = Worksheets("Sheet1").Cells(1, B) Worksheets("Sheet2").Cells(B - 3 + D, 13) = Worksheets("Sheet1").Cells(C + 1, 2) Next D = C * 4 Next 'Sheet2の表の行数を調べる Sheets("Sheet2").Select E = Worksheets("sheet2").Range("F65536").End(xlUp).Row '0欄の確認 For F = E To 1 Step -1 If Worksheets("Sheet2").Cells(F, 6) = 0 Then '0の場合は行を削除する Cells(F, 1).EntireRow.Delete End If Next End Sub カウントするとデータ個数がSheet1で約１２０件になりSheet2においては、４倍になりますので約４８０件になります。 そこで Sheet1において１２件ごとに、Sheet2,3,4...としたいのです。 Sh1 NO.1～12がSheet2 Sh1 NO.13～24がSheet3 ... 10枚のシートにしたいのですが、このマクロにどのような命令を加えればよろしいでしょうか？ お手数ですがよろしくお願いいたします。
- 締切済み
- オフィス系ソフト
- (VBA)Splitの抜き出しが上手くいかない
以下のようなコードで「指定区切り文字」の前後で文字列を切り出しています。 添付画像見てもらえれば判ると思いますが B8セルからのB列の値が「29:08」が正解なのに 「29:08:00」と最後に「:00」が付いた形式になっています。 （B13で1時間を過ぎると正常になっています。） このため、以後のE及びF列の書き出しもおかしな値となりました。 どのように修正すれば良いでしょうか ？ Option Explicit Sub Chapter_Plus() Dim I As Long Dim J As Long Dim TEMP As Variant Dim SepChr As String Dim WS1 As Worksheet Dim WS2 As Worksheet Dim EndLow As Long Dim LineData As String Dim OutText As String Dim byteData() As Byte '一時格納用 Set WS1 = Worksheets("DATA") Set WS2 = Worksheets("Chapter") 'シートの初期化 WS1.Range("B3:H100").Clear WS2.Range("A1:A100").Clear SepChr = InputBox("指定文字を入力してください。", "区切り文字入力", " ") 'TotalLength = InputBox("時間を(h:mm:ss)で入力してください。", "ファイルサイズ入力") EndLow = WS1.Cells(Rows.Count, "A").End(xlUp).Row With WS1 '区切り文字で切り出す For I = 3 To EndLow TEMP = Split(.Cells(I, "A"), SepChr) .Cells(I, "B") = TEMP(0) .Cells(I, "C") = TEMP(1) Next '仮チャプター書き出す For I = 3 To EndLow .Cells(I, "E").Value = Format(.Cells(I, "B").Value, "hh:mm:ss") .Cells(I, "F").Value = Format(.Cells(I + 1, "B").Value, "hh:mm:ss") .Cells(I, "G").Value = .Cells(I, "C").Value Next '番号 For I = 3 To EndLow .Cells(I, "H").Value = CStr(Format(I - 2, "'00")) Next End With End SUB
- ベストアンサー
- Excel（エクセル）
- エクセルの簡単なマクロ機能を追加したいのです
既存のエクセルマクロ（Sub チェック()以下です）に下記の内容のマクロを付け足したいです。 教えていただけないでしょうか。 付け足したい条件です： Sheet2のC列に 0 があれば Sheet1のB列に 愛 と（[太字]でセルの背景色を[灰色25%]にして）入れたいです 恐れ入りますがご存じの方がいらっしゃりましたら教えていただきたく何卒よろしくお願いいたします。 ----------------------------------------------- Sub チェック() Dim Ws1 As Worksheet Dim Ws2 As Worksheet Dim myRange1 As Range Dim myRange2 As Range Dim c1 As Range Dim c2 As Range Dim myCt As Long Set Ws1 = Worksheets("Sheet1") Set Ws2 = Worksheets("Sheet2") Set myRange1 = Ws1.Range("A1", Ws1.Cells(Rows.Count, "A").End(xlUp)) Set myRange2 = Ws2.Range("A1", Ws2.Cells(Rows.Count, "A").End(xlUp)) For Each c1 In myRange1 myCt = 0 For Each c2 In myRange2 If c2.Value = c1.Value Then If c2.Offset(, 1).Value = "" Then c1.Offset(, 1).Interior.ColorIndex = 3 Else c1.Offset(, 1).Value = c2.Offset(, 1).Value End If myCt = myCt + 1 End If Next c2 If myCt > 1 Then c1.Offset(, 1).Interior.ColorIndex = 10 Next c1 Set Ws1 = Nothing Set Ws2 = Nothing Set myRange1 = Nothing Set myRange2 = Nothing End Sub
- 締切済み
- その他MS Office製品
- エクセルで在庫表を作ろうとしています
エクセルで在庫表を作ろうとしているのですが、躓いてしまって困っています。 TEST1 コードを手入力した後実行 TEST2 出庫数を入力した後実行 Option Explicit Option Base 1 Sub TEST1() 'コードを手入力した後実行 Dim ws1 As Worksheet Dim ws2 As Worksheet Dim r&, i& Dim vL1 As String Dim vL2 As Long Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") r = ws1.Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To r vL1 = Application.WorksheetFunction.VLookup(ws1.Cells(i, 1), ws2.Range("A2:IV65536"), 2, False) ws1.Cells(i, 1).Offset(, 1) = vL1 vL2 = Application.WorksheetFunction.VLookup(ws1.Cells(i, 1), ws2.Range("A2:IV65536"), 3, False) ws1.Cells(i, 1).Offset(, 2) = vL2 Next i End Sub Sub TEST2() '出庫数を入力した後実行 Dim ws1 As Worksheet Dim ws2 As Worksheet Dim r&, i& Dim vL2 As Long Dim vL3 As String Dim syukko As Long Dim fnd As Range Dim zaiko As Long Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") r = ws1.Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To r If ws1.Cells(i, 4) > 0 Then syukko = ws1.Cells(4, 1).Offset(, 3).Value vL2 = Application.WorksheetFunction.VLookup(ws1.Cells(3, 2), ws2.Range("A2:IV65536"), 3, False) Set fnd = ws2.Range("A:A").Find(ws1.Cells(i, 1)) If fnd Is Nothing = False Then zaiko = vL2 - syukko fnd.Offset(, 2) = zaiko End If MsgBox ws1.Cells(i, 2) & "を" & syukko & "出庫します" & vbLf & "在庫は" & zaiko & "になります。" Else MsgBox "出庫数を入力して下さい" Exit Sub End If Next i ws1.Range("A2:D65536").ClearContents End Sub ここまでは作りました。 ですが、プロシージャの外では無効です と出てしまいます。 どうすればよいのでしょうか。 教えて下さい。 シート1のＢ2にコード・C3に名前・D2に現在個数・E2に出庫数を入力します。 実際にはB3からすうじを入力し、コードを入力すれば自然に名前と現在個数を シート2から探してくるようにしたいです。 シート2にはA列にコード、B列に名前、C列に現在庫数が載っている表があります(量が半端ではないです) 出来れば、1度出庫数を入れたら、次開いた時にシート2のC列にある現在個数が自然に減っていて、シート1にはフォームしか残らない状態にしたいです。 お願いします<m(__)m>
- 締切済み
- オフィス系ソフト
- 条件にあてはまるデータの数をカウントするエクセルVBA
下記のようにA列に1～3のコードがありB～E列には測定値があります。 B列以降の測定値のカウント（+3の個数、+2の個数…）を列ごとにVBAでカウントしてます。 A列に関係なくカウントするコードは記述して実行できましたが A列の条件が1の時だけカウントするVBAが良くわかりません。 シート A B C ・・・E 1 -1 +1 ・・・ 1 +2 0 2 0 0 3 -3 0 1 -1 +3 101行目以降 +3 カウント数 … +2 〃 +1 〃 0 〃 -1 〃 -2 〃 -3 〃 A列に関係なくカウントするコード sub カウント() Dim 行 As Long Dim 列 As Long For 列 = 2 To 5 For 行 = 101 To 107 Cells(行, 列).Value = Application.WorksheetFunction.CountIf(Range(Cells(2, 列), Cells(100, 列)), Cells(行, 1)) Next 行 Next 列 End Sub
- ベストアンサー
- Visual Basic
- 複数ファイルの１つのシート中の総行数を求めるには
大変お世話になっております。 複数ファイルの１つのシート(カテーログ)中の最終行数を求めるのに、下記のマクロを書いて実行しましたが、エラーは出ませんが総行数など、何も反応がありません。なにも出力しない原因がお分かりでしたら、ご教示頂けると大変たすかります。まだまだマクロは超初心者です。 出力したい情報は、ファイル名とA列の3行目～最終行の総行数です。 Sub データ総行数求め() Dim fpath As String, fname As String Dim wb As Workbook, ws As Worksheet Dim crow As Long, cnt As Long fpath = "C:\Users\Owner\Documents\連結作業\202304-202309\)" fname = Dir(fpath & "*.xlsx") Set ws = ThisWorkbook.Worksheets("test") crow = 1 Do Until (fname = "") Set wb = Workbooks.Open(fpath & fname) If (sheet_chk(wb, "カテーログ") = True) Then cnt = count_row(wb.Worksheets("カテーログ")) Worksheets("カテーログ").Range("A3").Value ws.Cells(crow, 1).Value = fname ws.Cells(crow, 2).Value = "カテーログ" ws.Cells(crow, 3).Value = cnt crow = crow + 1 End If wb.Close fname = Dir() Loop End Sub '戻り値の定義 Function count_row(ByVal ws As Worksheet) As Long Dim k As Long, tmp As Long count_row = 0 For k = 1 To 256 tmp = ws.Cells(ws.Rows.Count, k).End(xlUp).Row If (tmp > count_row) Then count_row = tmp Next End Function Function sheet_chk(ByVal wb As Workbook, ByVal msg As String) As Boolean Dim w As Worksheet sheet_chk = False For Each w In wb.Worksheets If (w.Name = msg) Then sheet_chk = True Exit For End If Next End Function
- ベストアンサー
- Excel（エクセル）
- エクセルののマクロについて教えてください
Sub search() Dim i As Long, lastCol As Long, c As Range, str As String, wS As Worksheet Set wS = Worksheets("sheet2") wS.Cells.Clear str = Application.InputBox("検索内容を入力") Application.ScreenUpdating = False With Worksheets("sheet1") lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column .Columns(lastCol + 1).Insert For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row Set c = Range(.Cells(i, "A"), .Cells(i, lastCol)).Find(what:=str, LookIn:=xlValues, lookat:=xlWhole) If Not c Is Nothing Then .Cells(i, lastCol + 1) = 1 End If Next i If WorksheetFunction.CountIf(.Columns(lastCol + 1), 1) > 0 Then .Range("A1").AutoFilter field:=lastCol + 1, Criteria1:=1 .Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy wS.Range("A1") wS.Columns.AutoFit wS.Columns(lastCol + 1).Delete wS.Activate .Columns(lastCol + 1).Delete .AutoFilterMode = False Else MsgBox "該当データなし" End If End With Application.ScreenUpdating = True End Sub エクセルで上のシステムをネットから持ってきました。 上から5行目のinputboxを"Sheet3"のA列からデータを持ってきてプルダウンで表示させたいのですがユーザーフォームでオブジェクトを組まないで表示させる方法を教えてください
- 締切済み
- Excel（エクセル）
- 変名が思うように処理されないのは ？
現在、以下のようなコードでA列のファイル名に指定の不要文字が含まれる場合、削除して変名を行っています。 エラーは出ないのですが、同名チェックが想定と違うのか上手く処理できていません。 具体的には、 不要文字が無いのに(１)が追加されて変名される場合があります。 不具合の原因が判るでしょうか？ Option Explicit Sub ファイル変更_部分削除() Dim Fso As Object 'FileSystemObject Dim Folder As Object 'Folder Dim File As Object 'File Dim FolderPath As String 'フォルダパス Dim Target As Variant '削除したい文字列 Dim ws1 As Worksheet, ws2 As Worksheet Set ws1 = Worksheets("Target") Set ws2 = Worksheets("DEL") 'FileSystemObjectを作成 Set Fso = CreateObject("Scripting.FileSystemObject") 'フォルダパスを指定 FolderPath = "C:\Target\" 'Folderオブジェクトを取得 Set Folder = Fso.GetFolder(FolderPath) Worksheets("Target").Cells.Clear ws1.Range("A1") = "修正後のファイル名" ws1.Range("A1").Font.Bold = True ws1.Range("B1") = "拡張子" ws1.Range("B1").Font.Bold = True ws1.Range("C1") = "元ファイル名_退避" ws1.Range("C1").Font.Bold = True Dim ext As String Dim num As Long num = 2 For Each File In Folder.Files ext = Fso.getextensionname(File.Name) Select Case ext Case "ts", "mkv", "mp4" '元ファイル名及び同拡張子を出力 ws1.Cells(num, "A").Value = Fso.GetBaseName(File.Name) ws1.Cells(num, "B").Value = Fso.getextensionname(File.Name) num = num + 1 Case Else End Select Next Dim lc1 As Long, lc2 As Long lc1 = ws1.Cells(Rows.Count, "A").End(xlUp).Row '最終行番号の取得 lc2 = ws2.Cells(Rows.Count, "B").End(xlUp).Row '元ファイル名を退避 ws1.Range(ws1.Cells(2, "A"), ws1.Cells(lc1, "A")).Copy ws1.Cells(2, "C").PasteSpecial ws1.Columns("A:C").AutoFit '-------------------------------------------------------- 'Replacedメソッド / ワイルドカードを使って置換() Dim DelMojis As String '指定文字列を格納する変数 Dim i As Long Dim Fix1 As String For i = 2 To lc2 With ws1 .Range(.Cells(2, "A"), .Cells(lc1, "A")).Replace what:=Fix1, Replacement:="", LookAt:=xlPart End With Next For i = 2 To lc2 DelMojis = ws2.Cells(i, "B") '指定文字列を変数に代入 With ws1 .Range(.Cells(2, "A"), .Cells(lc1, "A")).Replace what:=DelMojis, Replacement:="", LookAt:=xlPart End With Next '---------------------------------------- 'ファイル名変更 Dim OldName As String '元のファイル名 Dim NewName As String '新しいファイル名 For i = 2 To lc1 With ws1 OldName = FolderPath & .Cells(i, "C") & "." & .Cells(i, "B") NewName = FolderPath & .Cells(i, "A") & "." & .Cells(i, "B") End With With Fso 'fso=CreateObject("Scripting.FileSystemObject") '移動先に同名のファイルがあるかチェック If .FileExists(NewName) Then ' 同名がある場合は、NewNameの最後に(1)を追加する Dim k As Long k = InStrRev(NewName, ".") NewName = Left(NewName, k - 1) & "(1)" & Right(NewName, Len(NewName) - k + 1) .MoveFile OldName, NewName Else 'ファイルを移動 .MoveFile OldName, NewName End If End With '-------------------------- Next End Sub
- ベストアンサー
- Excel（エクセル）
- マクロ ランキングの表を作成し、HTML出力
A1、B1、C1…にテキストを入れます。 A1 スペシャル B1 （空白） C1 （空白） A2 スズキ B2 2000 C2 1000 A3 タナカ B3 1000 C3 800 ・ ・ 下記のプログラムはセルに空白があるとそこでループが止まってしまいます。 セルの空白で止まるのではなく、最終尾の行に全て空白があると判断した時点でループをストップしたいのです。 上記ではB1とC1に空白があり、B1で止まってしまいます。 アドバイスをお願いします。 Sub convertHTML() Dim ws As Worksheet Dim htmlFile As String Dim i As Long Dim LineData As String Set ws = ThisWorkbook.Worksheets(1) htmlFile = ActiveWorkbook.Path & "\Sample.html" Open htmlFile For Output As #1 i = 1 Do While ws.Cells(i, 1).Value <> "" LineData = "<div>" & ws.Cells(i, 1).Value & "</div>" & vbCrLf LineData = LineData & "<p>" & ws.Cells(i, 2).Value & "</p>" & vbCrLf LineData = LineData & "<span>" & ws.Cells(i, 3).Value & "</span>" & vbCrLf Print #1, LineData i = i + 1 Loop Close #1 MsgBox htmlFile & "に書き出しました" End Sub
- ベストアンサー
- Excel（エクセル）
- エクセルのマクロで複数セル指定は？
以前（7月22日 質問No.936181）の質問でご回答を頂いたマクロなんですが、 Private Sub Worksheet_Change(ByVal Target As Range) Dim MyData As String Dim i As Integer Dim ImaNanji As String Dim SakkiNanji As String Dim ImaNanpun As String Dim SakkiNanpun As String SakkiNanpun = Cells(2, 3).Value ImaNanji = Cells(1, 3).Value ImaNanpun = Mid(ImaNanji, Len(ImaNanji) - 4, 2) If ImaNanpun <> SakkiNanpun Then Application.EnableEvents = False For i = 10 To 2 Step -1 MyData = Cells(i - 1, 2).Value Cells(i, 2).Value = MyData Next i MyData = Cells(1, 1).Value Cells(1, 2).Value = MyData Cells(2, 3).Value = ImaNanpun Application.EnableEvents = True End If End Sub A1のデータをB1からB10に一分おきにつぎつぎに書き込むというものなんですが、ひとつのセルではなく複数のセル（例えばA1からA30の30個のセル）をいっぺんに書き込むようにしたいのですが可能でしょうか？ よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
お礼
確かにそうですね。もともとsumproductで利用していた表だったので、そのまま利用しようとしすぎました。大変参考になり、ありがとうございます。