VBA関数について

質問

添付画像左側のデータベースから添付画像右側のように検索結果をVBAで求めたいのですが、なかなか上手くいきません。
回答よろしくお願いします。

回答No.3

kagakusuki · ベストアンサー

>今、実行してみたのですが実行時エラー438 オブジェクトはこのプロパティまたはメソッドをサポートしていません。と表示されました。

　済みませんが、それだけの情報ではどこが上手く行っていないのかが解りません。
　Visual Basicのウィンドウを開いた際に、お伝えしたVBAの構文の中のどこがエラーとなっているのか(どこが黄色で塗り潰されているのか)を御教え願います。
　前々回の回答の後、こちらでも質問者様の添付画像の様にデータを手入力して、前述のVBAで処理を行ってみているのですが、その際には正しく結果が出る事を確認しております。
　それからもう一点確認しておきたい事があるのですが、もしかしますと、質問者様が御使いになられているExcelのバージョンは、Excel2007よりも前のバージョンでは無いでしょうか？
　Excel2007よりも前のバージョンではCOUNTIFS関数やSUMIFS関数が使えませんので、その事が影響している恐れがあります。

補足

返答ありがとうございます。

エクセルは2010を使用しております。
コードを何度も確認したのですがミスは発見できませんでした。

エラーメッセージの時は普通は黄色でマーキングされるのですがそれもありません。

回答者様が問題なく実行できているので私の使用してるエクセルのソフトに何らかの異常があるのでしょうか。

回答No.2

kagakusuki

済みません、前回の回答で述べたVBAの構文において

'配達先×数量を入力

の次の所に記述されている

'Range(DetailColumnR & FirstRowR & ":" & DetailColumnR & LastRowR).Formula = "="","""

という部分は、不要な部分を削除し忘れただけのものです。
　それから、

c.Value = Mid(c.Value, 2)

という箇所は間違いで、正しくは

c.Value = Mid(c.Value, 3)

でした。
　ですから、正しくは以下の様なVBAとなります。

Sub QNo9035948_VBA関数について()

Const FirstRowD As Long = 3 '実際のデータが入力されている一番上の行の行番号
Const ProductColumnD As String = "A" 'データベースにおいて品名が入力されている列
Const DelivColumnD As String = "B" 'データベースにおいて配達先が入力されている列
Const QuantColumnD As String = "C" 'データベースにおいて数量が入力されている列
Const FirstRowR As Long = 3 '検索結果(search Results)において抽出結果を書き込み始める行の1つ上の行の行番号
Const ProductColumnR As String = "E" '検索結果において品名を書き込む列
Const QuantColumnR As String = "F" '検索結果において配達合計数量を書き込む列
Const DetailColumnR As String = "G" '検索結果において配達先×数量を書き込む列

Dim LastRowD As Long, LastRowR As Long, c As Range, i As Long

'データが入力されている最終行の行番号を取得
LastRowD = Range(ProductColumnD & Rows.Count).End(xlUp).Row
If LastRowD < FirstRowD Then
MsgBox "データがありません。" & vbCrLf & "マクロを終了します。", _
vbExclamation, "データ無し"
Exit Sub
End If

'処理を高速化するため自動で行われる処理の中で不要なものをOFF
With Application
.ScreenUpdating = False 'モニター表示の更新をしない
.Calculation = xlManual '計算モードを手動に切り替え
End With

'品名の一覧を作成
Range(ProductColumnR & FirstRowR & ":" & DetailColumnR _
& Cells.SpecialCells(xlCellTypeLastCell).Row).Delete
With Range(ProductColumnR & FirstRowR).Resize(LastRowD - FirstRowD + 1, 1)
.Value = Range(ProductColumnD & FirstRowD).Resize(.Rows.Count, 1).Value
.RemoveDuplicates Columns:=1, Header:=xlNo
ActiveSheet.Sort.SortFields.Clear
.Sort Key1:=.Resize(1, 1), Order1:=xlAscending, Header:=xlNo
ActiveSheet.Sort.SortFields.Clear
End With

'検索結果の列においてデータが入力されている最終行の行番号を取得
LastRowR = Range(ProductColumnR & Rows.Count).End(xlUp).Row

With Range(QuantColumnR & FirstRowR & ":" & QuantColumnR & LastRowR)
.FormulaR1C1 = "=SUMIF(C" & Columns(ProductColumnD).Column & ",RC" & _
Columns(ProductColumnR).Column & ",C" & Columns(QuantColumnD).Column & ")" '配達合計数量を計算するWorksheet関数を入力
.Calculate '配達合計数量の計算を実行
.Value = .Value 'Worksheet関数の計算結果を値としてセルに再入力
End With

'配達先×数量を入力
For i = FirstRowD To LastRowD
If Range(ProductColumnD & i).Value <> "" _
And Range(DelivColumnD & i).Value <> "" Then
If WorksheetFunction.CountIfs( _
Range(ProductColumnD & FirstRowD).Resize(i - FirstRowD + 1), _
Range(ProductColumnD & i), _
Range(DelivColumnD & FirstRowD).Resize(i - FirstRowD + 1), _
Range(DelivColumnD & i)) _
= 1 Then
Set c = Range(DetailColumnR & WorksheetFunction. _
Match(Range(ProductColumnD & i).Value, Columns(ProductColumnR), 0))
c.Value = c.Value & ", " & Range(DelivColumnD & i).Value & "×" & _
WorksheetFunction.SumIfs(Columns(QuantColumnD), Columns(ProductColumnD), _
Range(ProductColumnR & c.Row).Value, Columns(DelivColumnD), _
Range(DelivColumnD & i).Value)
End If
End If
Next i
For Each c In _
Range(DetailColumnR & FirstRowR & ":" & DetailColumnR & LastRowR)
c.Value = Mid(c.Value, 3)
Next c

With Application
.Calculation = xlAutomatic '計算モードを自動に切り替え
.ScreenUpdating = False 'モニター表示の更新を行う
End With

End Sub

補足

早速の回答ありがとうございました。
今、実行してみたのですが実行時エラー438
オブジェクトはこのプロパティまたはメソッドをサポートしていません。と表示されました。
また、E3セルからF7セルまでは理想的に入力されましたがG列は空欄のままです。

お時間ある時で構いませんので、また回答宜しくお願い致します。

回答No.1

kagakusuki

今ちょっと時間が無いので、動作確認をしておりませんが、次の様なVBAでは如何でしょうか？

Sub QNo9035948_VBA関数について()

Const FirstRowD As Long = 3 '実際のデータが入力されている一番上の行の行番号
Const ProductColumnD As String = "A" 'データベースにおいて品名が入力されている列
Const DelivColumnD As String = "B" 'データベースにおいて配達先が入力されている列
Const QuantColumnD As String = "C" 'データベースにおいて数量が入力されている列
Const FirstRowR As Long = 3 '検索結果(search Results)において抽出結果を書き込み始める行の1つ上の行の行番号
Const ProductColumnR As String = "E" '検索結果において品名を書き込む列
Const QuantColumnR As String = "F" '検索結果において配達合計数量を書き込む列
Const DetailColumnR As String = "G" '検索結果において配達先×数量を書き込む列

Dim LastRowD As Long, LastRowR As Long, c As Range, i As Long

'データが入力されている最終行の行番号を取得
LastRowD = Range(ProductColumnD & Rows.Count).End(xlUp).Row
If LastRowD < FirstRowD Then
MsgBox "データがありません。" & vbCrLf & "マクロを終了します。", _
vbExclamation, "データ無し"
Exit Sub
End If

'処理を高速化するため自動で行われる処理の中で不要なものをOFF
With Application
.ScreenUpdating = False 'モニター表示の更新をしない
.Calculation = xlManual '計算モードを手動に切り替え
End With

'品名の一覧を作成
Range(ProductColumnR & FirstRowR & ":" & DetailColumnR _
& Cells.SpecialCells(xlCellTypeLastCell).Row).Delete
With Range(ProductColumnR & FirstRowR).Resize(LastRowD - FirstRowD + 1, 1)
.Value = Range(ProductColumnD & FirstRowD).Resize(.Rows.Count, 1).Value
.RemoveDuplicates Columns:=1, Header:=xlNo
ActiveSheet.Sort.SortFields.Clear
.Sort Key1:=.Resize(1, 1), Order1:=xlAscending, Header:=xlNo
ActiveSheet.Sort.SortFields.Clear
End With

'検索結果の列においてデータが入力されている最終行の行番号を取得
LastRowR = Range(ProductColumnR & Rows.Count).End(xlUp).Row

With Range(QuantColumnR & FirstRowR & ":" & QuantColumnR & LastRowR)
.FormulaR1C1 = "=SUMIF(C" & Columns(ProductColumnD).Column & ",RC" & _
Columns(ProductColumnR).Column & ",C" & Columns(QuantColumnD).Column & ")" '配達合計数量を計算するWorksheet関数を入力
.Calculate '配達合計数量の計算を実行
.Value = .Value 'Worksheet関数の計算結果を値としてセルに再入力
End With

'配達先×数量を入力
'Range(DetailColumnR & FirstRowR & ":" & DetailColumnR & LastRowR).Formula = "="","""
For i = FirstRowD To LastRowD
If Range(ProductColumnD & i).Value <> "" _
And Range(DelivColumnD & i).Value <> "" Then
If WorksheetFunction.CountIfs( _
Range(ProductColumnD & FirstRowD).Resize(i - FirstRowD + 1), _
Range(ProductColumnD & i), _
Range(DelivColumnD & FirstRowD).Resize(i - FirstRowD + 1), _
Range(DelivColumnD & i)) _
= 1 Then
Set c = Range(DetailColumnR & WorksheetFunction. _
Match(Range(ProductColumnD & i).Value, Columns(ProductColumnR), 0))
c.Value = c.Value & ", " & Range(DelivColumnD & i).Value & "×" & _
WorksheetFunction.SumIfs(Columns(QuantColumnD), Columns(ProductColumnD), _
Range(ProductColumnR & c.Row).Value, Columns(DelivColumnD), _
Range(DelivColumnD & i).Value)
End If
End If
Next i
For Each c In _
Range(DetailColumnR & FirstRowR & ":" & DetailColumnR & LastRowR)
c.Value = Mid(c.Value, 2)
Next c

With Application
.Calculation = xlAutomatic '計算モードを自動に切り替え
.ScreenUpdating = False 'モニター表示の更新を行う
End With

End Sub