[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『複数のシートを参照して売り上げを出したい』（peridot）
すみません、助けてください
Excelで複数のシートを参照して、その日の売上を出したいのですが、参照がうまく行きません。
★シート"箱サンプル"(データシート)
A B C D E F G H I J K L 1 SK作業 合計 2 記号 媒体名 件数 記号 媒体名 件数 記号 媒体名 件数 3 SK1 KZ SK2 KZ 2 SK KZ 2 4 SK1 MZ SK2 MZ 5 SK1 HY 82 SK2 HY 4 SK HY 86 6 SK1 FR 11 SK2 FR SK FR 11 7 VA1 KK 1516 VA2 KK 224 VA KK 1740 8 VE1 KK 9 VE2 KK 4 VE KK 13 9 VS1 10P 6192 VS2 10P 672 VS 10P 6864 10 VS3 10P 1008 VS 10P 1008
★シート"有料"(データシート) （フォームは「箱サンプル」と同じ）
★シート"単価マスタ" A B C D E F G H I 1 単価表 2 記号 媒体名 基本単価 追加分 付帯業務 区分 基本コスト 単価 3 SK KZ 19 1 1.2 1.5 22.7 17.0 4 SK MZ 19 1 1.2 1.5 22.7 17.0 5 SK HY 19 2 0 1.5 22.5 16.9 6 SK FR 19 0 0 1.5 20.5 15.4 7 VA KK 19 2 1.2 1.5 23.7 17.8 8 VE KK 19 0 0 1.5 20.5 15.4 9 VS 10P 19 0 12.2 1.5 32.7 24.5
上記のようなデータシートと単価マスタがあります。
データシートには、その日に発生する業務の記号・媒体・件数がA～Gに入力されます。 その合計件数がJ～L列に関数で表示されます。 （A～Gの中で件数が0のものはJ～L列のその行は空白になります）
「記号」「媒体」はそれぞれ同じものがあります。 基本的にA列の記号は「xx1」、E列の記号は「xx2」となっていますが、ごく稀に「xx3」が発生すると A列に「xx3」が記載されます。 「合計」の記号はA列・E列から数字を取り除いたものです。
単価マスタの「基本コスト」（H列）はD～G列の合計、「単価」（I列）はH列×0.75の数式が入っています。
それで、「合計」の部分と単価マスタを照合して、それぞれの売上を下記のように出したいです。 ○売上＝データシートの合計件数×単価マスタの単価
★シート"売上" A B C D E 1 記号 媒体 件数 単価 売上 2 SK KZ 2 17.0 34.0 3 SK HY 86 16.9 1453.4 4 SK FR 11 15.4 169.4 5 VA KK 1740 17.8 3097.2 6 VE 10P 13 15.4 200.2 7 VS 10P 7872 24.5 19286.4 ～～～～～～～～ 45 合計 SUM(C列) SUM(E列)
このように「売上」シートに一覧表を作りたいのですが、最初VLOOKUPで抽出しようと思ったのですが シート"箱サンプル"の9～10行目のように見出しが同じものがあったりするのでうまくいきません。 マクロでやろうと思ったのですが、データシートの「合計」の中から件数があるものを抽出し、 その「記号＆媒体名」の組み合わせが一致するものを「単価マスタ」で探して取り出す＆ シート"箱サンプル"の9～10行目のように見出しが同じものを一つにまとめるというのが よくわかりません…
↓とりあえず「箱サンプル」シートからデータを抜き出そうとしたコード
Option Explicit
Sub 売上データ()
Dim i As Long Dim j As Long Dim k As Long Dim tenso As String Dim baitai As String Dim qty As Long Dim cost As Long Dim sales As Long Dim sh1 As Worksheet Dim sh2 As Worksheet Dim sh3 As Worksheet
Set sh1 = ThisWorkbook.Sheets("箱サンプル")
Set sh2 = ThisWorkbook.Sheets("有料")
Set sh3 = ThisWorkbook.Sheets("単価マスタ")
With Sheets("売上")
For j = 3 To .Cells(Rows.Count, 1).End(xlUp).Row
If sh1.Cells(j, 10).Value <> "" Then
For i = 3 To sh1.Cells(Rows.Count, 1).End(xlUp).Row - 1
.Cells(i, 1).Value = sh1.Cells(j, 10).Value
.Cells(i, 2).Value = sh1.Cells(j, 11).Value
.Cells(i, 3).Value = sh1.Cells(j, 12).Value
'.Cells(i, 4).Value = 単価マスタから一致するものを抽出？
.Cells(i, 5).Formula = "=C" & i & "*D" & i
Next i
End If
Next j
End With
Set sh1 = Nothing
Set sh2 = Nothing
Set sh3 = Nothing
End Sub
このコードを実行しましたが、「箱サンプル」シートの最終行だけが「売上」シートにずらーっと並んでしまいます。 最初からつまづいて、単価マスタを参照したり同じ「記号＆媒体名」の組み合わせを統合したり… もさっぱり分かりません。
どのようにすればよいかお教えください。 Excelのバージョンは2007です。
★シート"箱サンプル"(データシート)
★シート"有料"(データシート) （フォームは「箱サンプル」と同じ）
の関係が解りません？
(Bun)
すみません、「箱サンプル」「有料」両方のシートからデータを抜き出して「単価マスタ」シートと照合、 「箱サンプル」「有料」にあるデータの売上をまとめて「売上」シートに書き出したいのです。
（peridot）
>すみません、「箱サンプル」「有料」両方のシートからデータを抜き出して「単価マスタ」シートと照合、 >「箱サンプル」「有料」にあるデータの売上をまとめて「売上」シートに書き出したいのです。
と言う事は、「箱サンプル」「有料」両方のシートは、同じ意味のデータとして合算して善いんですね？
(Bun)
>と言う事は、「箱サンプル」「有料」両方のシートは、同じ意味のデータとして合算して善いんですね？ はい、そうです。
(peridot)
"箱サンプル" のデータを、"売上" へ転記処理するサンプルです。 Dic を利用して、単価マスタから、該当単価を引いてきます。
Sub test() Dim i&, j&, n&, S$, Sh As Worksheet Dim D As Object
Set D = CreateObject("scripting.dictionary")
Set Sh = Sheets("売上")
With Sheets("単価マスタ") 'Dicへ単価セット
For i = 3 To .Cells(.Rows.Count, "b").End(xlUp).Row
S = .Cells(i, 2).Value & .Cells(i, 3).Value
D(S) = .Cells(i, "i").Value
Next
End With
n = 1: S = ""
With Sheets("箱サンプル")
For i = 3 To .Cells(.Rows.Count, 1).End(xlUp).Row
If .Cells(i, "l").Value <> "" Then
If .Cells(i, "j").Value & .Cells(i, "k").Value <> S Then
n = n + 1
S = .Cells(i, "j").Value & .Cells(i, "k").Value
Sh.Cells(n, 1).Value = .Cells(i, "j").Value '記号
Sh.Cells(n, 2).Value = .Cells(i, "k").Value '媒体
Sh.Cells(n, 3).Value = .Cells(i, "l").Value '件数
Else
Sh.Cells(n, 3).Value = Sh.Cells(n, 3).Value + .Cells(i, "l").Value '件数
End If
Sh.Cells(n, 4).Value = D(S)
Sh.Cells(n, 5).Value = Sh.Cells(n, 3).Value * Sh.Cells(n, 4).Value
End If
Next
End With
Set D = Nothing
End Sub
(HM)
こんなのでは？ Dictionaryを使って集計を行っています
Option Explicit
Public Sub Sample()
Dim i As Long
Dim lngCount As Long
Dim lngRows As Long
Dim rngList1 As Range
Dim rngList2 As Range
Dim rngTable As Range
Dim rngResult As Range
Dim vntData As Variant
Dim vntResult As Variant
Dim vntKey As Variant
Dim dicIndex As Object
Dim strProm As String
'箱サンプルの先頭セル位置を基準とする（先頭列の列見出し「記号」のセル位置）
Set rngList1 = Worksheets("箱サンプル").Range("A2")
'有料の先頭セル位置を基準とする（先頭列の列見出し「記号」のセル位置）
Set rngList2 = Worksheets("有料").Range("A2")
'単価マスタの先頭セル位置を基準とする（先頭列の列見出し「記号」のセル位置）
Set rngTable = Worksheets("単価マスタ").Range("B2")
'結果出力の先頭セル位置を基準とする（先頭列の列見出し「記号」のセル位置）
Set rngResult = Worksheets("売上").Range("A1")
'Dictionaryオブジェクトを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
'単価マスタに就いて
With rngTable
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'B、C列データを配列に取得
vntResult = .Offset(1).Resize(lngRows, 2).Value
'I列データを配列に取得
vntData = .Offset(1, 7).Resize(lngRows + 1).Value
End With
'結果用配列を作成
ReDim Preserve vntResult(1 To lngRows, 1 To 6)
'Dictionaryに「記号」「媒体名」をKeyとして登録し、「単価」を転記
With dicIndex
For i = 1 To lngRows
'「単価」を転記
vntResult(i, 4) = vntData(i, 1)
'最終列Flagを代入
vntResult(i, 6) = 0
'「記号」「媒体名」を登録
vntKey = vntResult(i, 1) & vbLf & vntResult(i, 2)
If Not .Exists(vntKey) Then
.Item(vntKey) = i
End If
Next i
End With
'箱サンプルデータを結果用配列に集計
AddUp rngList1, vntResult, dicIndex
'有料データを結果用配列に集計
AddUp rngList2, vntResult, dicIndex
'結果用配列の先頭行～最終行まで
For i = 1 To lngRows
'結果用配列に「件数」が無い場合
If IsEmpty(vntResult(i, 3)) Then
'削除Flagを立てる
vntResult(i, 6) = 1
'削除行をカウント
lngCount = lngCount + 1
Else
'「売上」を計算
vntResult(i, 5) = vntResult(i, 3) * vntResult(i, 4)
End If
Next i
If lngCount = lngRows Then
strProm = "箱サンプルと有料にデータが有りません"
GoTo Wayout
End If
'画面更新を停止
Application.ScreenUpdating = False
'売上シートに就いて
With rngResult
'元のデータをクリア
.CurrentRegion.Offset(1).ClearContents
'結果用配列を出力
.Offset(1).Resize(lngRows, 6).Value = vntResult
'削除FlagをKeyとして結果表を整列
DataSort .Offset(1).Resize(lngRows, 6), .Offset(1, 5)
'削除Flagが立っている行をクリア
.Offset(lngRows - lngCount + 1).Resize(lngCount, 6).ClearContents
'削除Flagをクリア
.Offset(1, 5).EntireColumn.ClearContents
'合計の数式を出力
lngRows = lngRows - lngCount
.Offset(lngRows + 1).Value = "合計"
.Offset(lngRows + 1, 2).FormulaR1C1 = "=SUM(R[-" & lngRows & "]C:R[-1]C)"
.Offset(lngRows + 1, 4).FormulaR1C1 = "=SUM(R[-" & lngRows & "]C:R[-1]C)"
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set dicIndex = Nothing
Set rngList1 = Nothing
Set rngList2 = Nothing
Set rngTable = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
Private Sub AddUp(rngList As Range, vntResult As Variant, dicIndex As Object)
Dim i As Long
Dim lngRows As Long
Dim vntData As Variant
Dim vntKey As Variant
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
Exit Sub
End If
'I列データを配列に取得
vntData = .Offset(1, 9).Resize(lngRows + 1, 3).Value
End With
'データを結果用配列に集計
With dicIndex
For i = 1 To lngRows
'「記号」「媒体名」がEmptyで無いなら
If Not IsEmpty(vntData(i, 1)) And Not IsEmpty(vntData(i, 2)) Then
'「記号」「媒体名」でKeyを作成
vntKey = vntData(i, 1) & vbLf & vntData(i, 2)
If .Exists(vntKey) Then
'「件数」を集計
vntResult(.Item(vntKey), 3) = vntResult(.Item(vntKey), 3) + vntData(i, 3)
End If
End If
Next i
End With
End Sub
Private Sub DataSort(rngScope As Range, _
rngKey As Range, _
Optional lngSortOrder As Long = xlAscending, _
Optional lngOrientation As Long = xlTopToBottom)
rngScope.Sort _
Key1:=rngKey, Order1:=lngSortOrder, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=lngOrientation, SortMethod:=xlStroke
End Sub
(Bun)
(HM)様(Bun)様 ありがとうございます。
すみません、仕様変更がありました。 データシート「箱サンプル」「有料」どちらのシートもなのですが、データをあるグループ毎に3～4つの表に分けて記載するようになりました。 （グループ分けの基準はその日の作業状況によるのでこれといった判断になるものがなく、入力する人がその都度グループ分けするとのこと）
なので、例えば
A B C D E F G H I J K L 1 SK作業 合計 2 記号 媒体名 件数 記号 媒体名 件数 記号 媒体名 件数 3 SK1 KZ SK2 KZ 2 SK KZ 2 4 SK1 MZ SK2 MZ 5 SK1 HY 82 SK2 HY 4 SK HY 86 6 SK1 FR 11 SK2 FR SK FR 11 7 VA1 KK 1516 VA2 KK 224 VA KK 1740 8 SUM(L3:L7) 9 記号 媒体名 件数 記号 媒体名 件数 記号 媒体名 件数 10 VE1 KK 9 VE2 KK 4 VE KK 13 11 VS1 10P 6192 VS2 10P 672 VS 10P 6864 12 VS3 10P 1008 VS 10P 1008
このように途中に小計行＆見出し行が入るようになります。 後からすみません… なので、合計を判断する際に「J列が空白でない＆"記号"という文字が入っていない」で条件分岐させたいのですが お二人のコードに自分で手を加えてみましたが「オブジェクト定義のエラーです」「型が一致しません」などのエラーが出ます。
申し訳ございませんが、条件分岐をどのようにすればよいかお教えいただけないでしょうか。
(peridot)
内容を一部修正しました。 データ数が多い場合は、配列内処理等が必要かも・・・。
Sub test2() Dim i&, j&, m&, n&, S$, Sh As Worksheet Dim D As Object, Sa, p&
Set D = CreateObject("scripting.dictionary")
Set Sh = Sheets("売上")
With Sheets("単価マスタ") 'Dicへ単価セット
For i = 3 To .Cells(.Rows.Count, "b").End(xlUp).Row
S = .Cells(i, 2).Value & .Cells(i, 3).Value
D(S) = .Cells(i, "i").Value
Next
End With
m = 1: S = ""
Sa = Array("箱サンプル", "有料")
Sh.UsedRange.Offset(1).ClearContents
For p = 0 To 1
With Sheets(Sa(p)) 'Sheets("箱サンプル")
For i = 3 To .Cells(.Rows.Count, 1).End(xlUp).Row
If .Cells(i, "j").Value <> "" And .Cells(i, "j").Value <> "記号" Then
S = .Cells(i, "j").Value & .Cells(i, "k").Value
If Not D.exists(S & "a") Then
m = m + 1
D(S & "a") = m '記入位置行番号
End If
n = D(S & "a")
If n > 0 Then
Sh.Cells(n, 1).Value = .Cells(i, "j").Value '記号
Sh.Cells(n, 2).Value = .Cells(i, "k").Value '媒体
Sh.Cells(n, 3).Value = Sh.Cells(n, 3).Value + .Cells(i, "l").Value '件数
Sh.Cells(n, 4).Value = D(S) '単価
Sh.Cells(n, 5).Value = Sh.Cells(n, 3).Value * Sh.Cells(n, 4).Value '売上
End If
End If
Next
End With
Next
With Sheets("売上")
i = .Cells(.Rows.Count, "a").End(xlUp).Row + 2
.Cells(i, "c").Value = Application.Sum(.Columns(3)) '計
.Cells(i, "e").Value = Application.Sum(.Columns(5)) '計
End With
Set D = Nothing
End Sub
私が列位置を勘違いして無ければ、全く元のコードのままで、修正無しで動くと思いますよ？
(Bun)
>このように途中に小計行＆見出し行が入るようになります。 >後からすみません… >なので、合計を判断する際に「J列が空白でない＆"記号"という文字が入っていない」で条件分岐させたいのですが
後、私のコードの場合は、単価表に無い「記号」「媒体」の組み合わせに就いては集計を蹴る様にしている筈なので、特に条件分岐をする必要は無いと思います
(Bun)
あ！、削除行が無いとエラーに成るのに気が付きました 以下の★印の行を追加して下さい
'売上シートに就いて
With rngResult
'元のデータをクリア
・
・
'削除FlagをKeyとして結果表を整列
DataSort .Offset(1).Resize(lngRows, 6), .Offset(1, 5)
'★削除行が在ったなら
If lngCount > 0 Then '★追加
'削除Flagが立っている行をクリア
.Offset(lngRows - lngCount + 1).Resize(lngCount, 6).ClearContents
End If '★追加
'削除Flagをクリア
.Offset(1, 5).EntireColumn.ClearContents
(Bun)
(HM)様(Bun)様 ありがとうございました！ 集計できました
(peridot)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.