VBAについて
添付画像左側のデータベースから添付画像右側のように検索結果をVBAで求めたいのですが、なかなか上手くいきません。
昨日、質問し回答を頂いたのですが私の使用しているパソコン(win7 EXCEL2010)が良くないのか、回答者様は問題なく動作したコードでも動作成功しませんでした。
以下のコードが回答頂いたものです。
宜しくお願い致します。
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
お礼
ありがとうございます。 名前を定義する方法としたいと思います。