Ｐａｇｅ 837 ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ 通常モードに戻る ┃ ＩＮＤＥＸ ┃ ≪前へ │ 次へ≫ ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ ▼データ抽出について ＴＫ 03/3/5(水) 13:36 ┗Re:データ抽出について ぴかる 03/3/5(水) 14:02 ┣Re:データ抽出について ＴＫ 03/3/5(水) 14:16 ┗Re:データ抽出について ＴＫ 03/3/5(水) 14:29 ┗すんません！ ぴかる 03/3/5(水) 14:58 ┗Re:すんません！ ＴＫ 03/3/5(水) 15:14 ┣Re:上手く無いけど Hirofumi 03/3/5(水) 21:51 ┃ ┣Re:上手く無いけど ichinose 03/3/5(水) 22:43 ┃ ┃ ┗Re:上手く無いけど ＴＫ 03/3/6(木) 0:05 ┃ ┗Re:上手く無いけど ＴＫ 03/3/6(木) 0:02 ┗フォローありがとうございました。 ぴかる 03/3/6(木) 9:02 ┗解決済みのようですが、せっかくなので... こう 03/3/6(木) 13:16 ─────────────────────────────────────── ■題名 ： データ抽出について ■名前 ： ＴＫ ■日付 ： 03/3/5(水) 13:36 -------------------------------------------------------------------------
| お世話になります。 この場で質問するには恐縮するのですが、 以下の点で困ってます。 いつもですと、スキルを持った人がおられて 対応できるのですが、急な依頼により私が対応 することになりました。 素人ですが宜しくお願いします。 （データ：エクセル、シート：sheet1） 日付 品名 色 金額 030301 A K 1000 030301 A K 1200 030301 A K 1400 030302 A K 1250 030302 B S 900 030302 B S 750 030304 B S 1450 030305 C L 7580 ・ ・ ・ ・ ・ ・ ・ ・ ・ ・ ・ ・ ・ ・ ・ ・ 030314 Z X 450 上記データの中で品名と色が同じ物の最初の日付１と 最後の日付２のデータを別ｼｰﾄ(sheet2)へ抽出したい。 その際、金額は総計金額としたい 日付1 日付2 品名 色 総計金額 030301 030302 A K 4850 030302 030304 B S 3100 ・ ・ ・ ・ ・ ・ ・ ・ 宜しくご教授お願い致します。 |
| ＴＫさん、こんにちは。 >日付1 日付2 品名 色 総計金額 >030301 030302 A K 4850 >030302 030304 B S 3100 ＶＢＡではなく、データベース関数で可能と思います。 日付1 … DMIN 日付2 … DMAX 総計金額 … DSUM ちょっとややこしい関数です。ヘルプ等で確認して下さい。 |
| ▼ぴかる さん： どうも早速の返答ありがとうございました。 > 日付1 … DMIN > 日付2 … DMAX > 総計金額 … DSUM >ちょっとややこしい関数です。ヘルプ等で確認して下さい。 エクセルベースで行ってみたいと思います。 |
| ▼ぴかる さん Ｔｋです。 早速エクセルの関数で行おうと思ったのですが、私の言葉不足だったのですが、 ﾛｯﾄ単位での集計を行いたいのです。 つまり、以下の様なケースの場合、エクセル関数では難しそうなのですが・・・。 日付 品名 色 金額 030301 A K 1000 030301 A K 1200 030301 A K 1400 030302 A K 1250 030302 B S 900 030302 B S 750 030304 B S 1450 030305 C L 7580 ・ ・ ・ ・ ・ ・ ・ ・ 030314 Z X 450 030401 A K 1200 030402 A K 1150 030403 B S 980 ・ ・ ・ ・ ・ ・ ・ ・ 030506 A K 1180 030507 A K 1200 ・ ・ ・ ・ ・ ・ ・ ・ 上記の場合、ﾛｯﾄ単位とは以下のようになります。 日付1 日付2 品名 色 総計金額 030301 030302 A K 4850 030302 030304 B S 3100 ・ ・ ・ ・ ・ ・ ・ ・ 030401 030402 A K 2300 ・ ・ ・ ・ ・ ・ ・ ・ 030506 030507 A K 1380 ・ ・ ・ ・ ・ ・ ・ ・ ﾛｯﾄとは、最上記表での連続したデータを日付で昇順にならべてあります。 その場合、品名と色とが連続的に続いたブロックをﾛｯﾄとしてます。 私の行いたいことの説明不足で申し訳有りませんが、宜しくお願いします。 |
| すんません！。日常業務もありまして本日中は、無理と思います。 ロットの意味も分かりました。時間が取れないのが残念です。 繰り返し文と条件分岐で可能とは思いますが・・・。 ていうことでどなたかお願い出来ませんか？。よろしくお願い致します。 |
| ▼ぴかる さん： ＴＫです。 ぴかるさん お気遣いどうもありがとうございます。 また、みなさんどうかご教授ねがいます。 宜しくお願いします。 >すんません！。日常業務もありまして本日中は、無理と思います。 >ロットの意味も分かりました。時間が取れないのが残念です。 >繰り返し文と条件分岐で可能とは思いますが・・・。 >ていうことでどなたかお願い出来ませんか？。よろしくお願い致します。 |
| なんか、スッキリ纏まらなくて気に入らないけれど こんなもんかな？ Public Sub AddUp() Dim i As Long Dim j As Long Dim vntData As Variant Dim vntAdd(4) As Variant Dim lngDataTop As Long Dim lngDataEnd As Long Dim lngListTop As Long Dim lngListEnd As Long Dim wksData As Worksheet Dim wksAdd As Worksheet Set wksData = Worksheets("sheet1") With wksData lngDataTop = 2 lngDataEnd = .Cells(65536, 1).End(xlUp).Row End With Set wksAdd = Worksheets("sheet2") With wksAdd lngListTop = 2 lngListEnd = .Cells(65536, 1).End(xlUp).Row End With 'Listを作成 i = lngDataTop With wksData.Cells(i, 1) vntData = Range(.Offset(, 0), .Offset(, 3)).Value End With vntAdd(0) = vntData(1, 1) For j = 1 To 4 vntAdd(j) = vntData(1, j) Next j i = i + 1 'データの最終まで繰り返し Do Until i > lngDataEnd With wksData.Cells(i, 1) vntData = Range(.Offset(, 0), .Offset(, 3)).Value End With 'もし、データの品名、色が集計配列のそれと同じなら If vntData(1, 2) = vntAdd(2) _ And vntData(1, 3) = vntAdd(3) Then '集計配列の２番に日付を代入 vntAdd(1) = vntData(1, 1) '集計配列の４番にデータの金額を加算 vntAdd(4) = vntAdd(4) + vntData(1, 4) Else '集計シートの最終行を更新 lngListEnd = lngListEnd + 1 With wksAdd.Cells(lngListEnd, 1) '書き込み行のA、B列の書式を文字に設定 Range(.Offset(, 0), .Offset(, 1)).NumberFormatLocal = "@" '書き込み行に集計配列を代入 Range(.Offset(, 0), .Offset(, 4)).Value = vntAdd End With vntAdd(0) = vntData(1, 1) For j = 1 To 4 vntAdd(j) = vntData(1, j) Next j End If 'データ用カウンタを更新 i = i + 1 Loop lngListEnd = lngListEnd + 1 With wksAdd.Cells(lngListEnd, 1) '書き込み行のA、B列の書式を文字に設定 Range(.Offset(, 0), .Offset(, 1)).NumberFormatLocal = "@" '書き込み行に集計配列を代入 Range(.Offset(, 0), .Offset(, 4)).Value = vntAdd End With Set wksData = Nothing Set wksAdd = Nothing End Sub |
| みなさん、こんばんは。 回答されているようですが､作っちゃったんで掲載させてください。 Sheet1のＥ列とＦ列を作業領域として使用しています。 Ｅ列Ｆ列も使用しているなら、別の列でもかまいませんが､ Offsetで参照していますのでコードを変えなければなりません。 '========================================================= Dim s2idx As Long 'sheet2の設定カレント行 '========================================================= Sub test() Dim v_yymm As Long '集計する年月 Dim v_max As Long '集計する年月の上限 Dim rng1 As Range 'sheet1の日付が入っている範囲 Dim rng2 As Range 'ロット単位のsheet1の日付が入っている範囲 Dim rng3 As Range 'ロット単位のsheet1のユニークな品名 Dim rng4 As Range 'ロット単位のsheet1のユニークな色 If get_min_max(v_yymm, v_max, rng1) = True Then 'sheet1の日付の最大・最小及び、Ａ列のデータ範囲取得成功？ v_yymm = Val(Mid$(Format$(Str(v_yymm), "000000"), 1, 4)) '集計年月セット v_max = Val(Mid$(Format$(Str(v_max), "000000"), 1, 4)) '上限年月セット s2idx = 2 Do While v_yymm <= v_max '集計する年月が上限以内ならループ If get_conbination(rng1, rng2, rng3, rng4, v_yymm) = True Then '品名と色の組み合わせを取得 Call 集計_proc(rng2, rng3, rng4) '集計処理 End If v_yymm = get_next_yymm(v_yymm) '次の年月取得 Loop If s2idx > 2 Then '集計データがあったら、数式を値に変換 With Worksheets(2).Range("a2", Worksheets(2).Cells(s2idx, 5)) .Value = .Value End With End If Else MsgBox "集計データ不備" End If End Sub '============================================================ Function get_next_yymm(yymm As Long) '次の年月を取得する Dim yymm_str As String yymm_str = Format$(Str(yymm + 1), "0000") If Val(Mid$(yymm_str, 3, 2)) = 13 Then get_next_yymm = (Val(Mid$(yymm_str, 1, 2)) + 1) * 100 + 1 Else get_next_yymm = Val(yymm_str) End If End Function '========================================================================== Function get_min_max(v_min As Long, v_max As Long, ar1 As Range) As Boolean '日付範囲の取得 get_min_max = False With Sheet1 Set ar1 = .Range("a1", .Cells(.Rows.Count, 1).End(xlUp)) If ar1.Address = Range("a1").Address Then Exit Function Set ar1 = ar1.Offset(1, 0).Resize(ar1.Rows.Count - 1, 1) End With v_min = WorksheetFunction.Min(ar1) v_max = WorksheetFunction.Max(ar1) If v_min > 0 And v_max > 0 Then get_min_max = True End If End Function '========================================================================= Function get_conbination(ar1 As Range, ar2 As Range, ar3 As Range, ar4 As Range, yymm As Long) As Boolean '品名と色の組み合わせを取得 get_conbination = False With ar1 .Offset(0, 4).FormulaR1C1 = "=if(and(r[0]c[-4]>=" & Format$(Str(yymm * 100 + 1), "000000") & ",r[0]c[-4]<=" & Format$(Str(yymm * 100 + 31), "000000") & ")=true,1,"""")" .Offset(0, 4).Value = .Offset(0, 4).Value Set ar2 = sp_rng(.Offset(0, 4)) If Not ar2 Is Nothing Then ar2.Value = "" Set ar2 = ar2.Offset(0, -4) With ar2 .Offset(0, 4).Resize(, 2).FormulaR1C1 = "=IF(rc[-3]<>"""",IF(COUNTIF(r" & .Item(1).Row & "c[-3]:rc[-3],rc[-3])=1,1,""""),"""")" .Offset(0, 4).Resize(, 2).Value = .Offset(0, 4).Resize(, 2).Value Set ar3 = sp_rng(.Offset(0, 4)) Set ar4 = sp_rng(.Offset(0, 5)) End With If (Not ar3 Is Nothing) And (Not ar4 Is Nothing) Then ar3.Value = "" ar4.Value = "" Set ar3 = ar3.Offset(0, -3) Set ar4 = ar4.Offset(0, -3) get_conbination = True End If End If End With End Function '======================================================================= Function sp_rng(rng As Range) As Range '値が入っているセル範囲の取得 On Error Resume Next Set sp_rng = rng.SpecialCells(xlCellTypeConstants) If Err.Number <> 0 Then Set sp_rng = Nothing End If On Error GoTo 0 End Function '======================================================================== Sub 集計_proc(rng1 As Range, rng2 As Range, rng3 As Range) 'Sheet2への集計書き込み処理 Dim shtnm As String Dim r2 As Range Dim r3 As Range shtnm = rng1.Parent.Name & "!" With Sheet2 For Each r2 In rng2 For Each r3 In rng3 .Cells(s2idx, 5).FormulaArray = "=sum(if(" & shtnm & rng1.Offset(0, 1).Address & "=" & shtnm & r2.Address & ",if(" & _ shtnm & rng1.Offset(0, 2).Address & "=" & shtnm & r3.Address & "," & shtnm & rng1.Offset(0, 3).Address & ",0),0))" If .Cells(s2idx, 5).Value <> 0 Then .Cells(s2idx, 1).FormulaArray = "=min(if(" & shtnm & rng1.Offset(0, 1).Address & "=" & shtnm & r2.Address & ",if(" & _ shtnm & rng1.Offset(0, 2).Address & "=" & shtnm & r3.Address & "," & shtnm & rng1.Address & ")))" .Cells(s2idx, 2).FormulaArray = "=max(if(" & shtnm & rng1.Offset(0, 1).Address & "=" & shtnm & r2.Address & ",if(" & _ shtnm & rng1.Offset(0, 2).Address & "=" & shtnm & r3.Address & "," & shtnm & rng1.Address & ")))" .Cells(s2idx, 3).Value = r2.Value .Cells(s2idx, 4).Value = r3.Value s2idx = s2idx + 1 End If Next Next End With End Sub |
| ▼ichinose さん： こんばんは。ＴＫです。 >みなさん、こんばんは。 >回答されているようですが､作っちゃったんで掲載させてください。 >Sheet1のＥ列とＦ列を作業領域として使用しています。 >Ｅ列Ｆ列も使用しているなら、別の列でもかまいませんが､ >Offsetで参照していますのでコードを変えなければなりません。 大変ありがたくおもいます。 これを機に勉強したいと思いますので、今後ともよろしくお願いします。 >'========================================================= >Dim s2idx As Long 'sheet2の設定カレント行 >'========================================================= >Sub test() > Dim v_yymm As Long '集計する年月 > Dim v_max As Long '集計する年月の上限 > Dim rng1 As Range 'sheet1の日付が入っている範囲 > Dim rng2 As Range 'ロット単位のsheet1の日付が入っている範囲 > Dim rng3 As Range 'ロット単位のsheet1のユニークな品名 > Dim rng4 As Range 'ロット単位のsheet1のユニークな色 > If get_min_max(v_yymm, v_max, rng1) = True Then 'sheet1の日付の最大・最小及び、Ａ列のデータ範囲取得成功？ > v_yymm = Val(Mid$(Format$(Str(v_yymm), "000000"), 1, 4)) '集計年月セット > v_max = Val(Mid$(Format$(Str(v_max), "000000"), 1, 4)) '上限年月セット > s2idx = 2 > Do While v_yymm <= v_max '集計する年月が上限以内ならループ > If get_conbination(rng1, rng2, rng3, rng4, v_yymm) = True Then '品名と色の組み合わせを取得 > Call 集計_proc(rng2, rng3, rng4) '集計処理 > End If > v_yymm = get_next_yymm(v_yymm) '次の年月取得 > Loop > If s2idx > 2 Then '集計データがあったら、数式を値に変換 > With Worksheets(2).Range("a2", Worksheets(2).Cells(s2idx, 5)) > .Value = .Value > End With > End If > > Else > MsgBox "集計データ不備" > End If >End Sub >'============================================================ >Function get_next_yymm(yymm As Long) >'次の年月を取得する > Dim yymm_str As String > yymm_str = Format$(Str(yymm + 1), "0000") > If Val(Mid$(yymm_str, 3, 2)) = 13 Then > get_next_yymm = (Val(Mid$(yymm_str, 1, 2)) + 1) * 100 + 1 > Else > get_next_yymm = Val(yymm_str) > End If >End Function >'========================================================================== >Function get_min_max(v_min As Long, v_max As Long, ar1 As Range) As Boolean >'日付範囲の取得 > get_min_max = False > With Sheet1 > Set ar1 = .Range("a1", .Cells(.Rows.Count, 1).End(xlUp)) > If ar1.Address = Range("a1").Address Then Exit Function > Set ar1 = ar1.Offset(1, 0).Resize(ar1.Rows.Count - 1, 1) > End With > v_min = WorksheetFunction.Min(ar1) > v_max = WorksheetFunction.Max(ar1) > If v_min > 0 And v_max > 0 Then > get_min_max = True > End If >End Function >'========================================================================= >Function get_conbination(ar1 As Range, ar2 As Range, ar3 As Range, ar4 As Range, yymm As Long) As Boolean >'品名と色の組み合わせを取得 > get_conbination = False > With ar1 > .Offset(0, 4).FormulaR1C1 = "=if(and(r[0]c[-4]>=" & Format$(Str(yymm * 100 + 1), "000000") & ",r[0]c[-4]<=" & Format$(Str(yymm * 100 + 31), "000000") & ")=true,1,"""")" > .Offset(0, 4).Value = .Offset(0, 4).Value > Set ar2 = sp_rng(.Offset(0, 4)) > If Not ar2 Is Nothing Then > ar2.Value = "" > Set ar2 = ar2.Offset(0, -4) > With ar2 > .Offset(0, 4).Resize(, 2).FormulaR1C1 = "=IF(rc[-3]<>"""",IF(COUNTIF(r" & .Item(1).Row & "c[-3]:rc[-3],rc[-3])=1,1,""""),"""")" > .Offset(0, 4).Resize(, 2).Value = .Offset(0, 4).Resize(, 2).Value > Set ar3 = sp_rng(.Offset(0, 4)) > Set ar4 = sp_rng(.Offset(0, 5)) > End With > If (Not ar3 Is Nothing) And (Not ar4 Is Nothing) Then > ar3.Value = "" > ar4.Value = "" > Set ar3 = ar3.Offset(0, -3) > Set ar4 = ar4.Offset(0, -3) > get_conbination = True > End If > End If > End With >End Function >'======================================================================= >Function sp_rng(rng As Range) As Range >'値が入っているセル範囲の取得 > On Error Resume Next > Set sp_rng = rng.SpecialCells(xlCellTypeConstants) > If Err.Number <> 0 Then > Set sp_rng = Nothing > End If > On Error GoTo 0 >End Function >'======================================================================== >Sub 集計_proc(rng1 As Range, rng2 As Range, rng3 As Range) >'Sheet2への集計書き込み処理 > Dim shtnm As String > Dim r2 As Range > Dim r3 As Range > shtnm = rng1.Parent.Name & "!" > With Sheet2 > For Each r2 In rng2 > For Each r3 In rng3 > .Cells(s2idx, 5).FormulaArray = "=sum(if(" & shtnm & rng1.Offset(0, 1).Address & "=" & shtnm & r2.Address & ",if(" & _ > shtnm & rng1.Offset(0, 2).Address & "=" & shtnm & r3.Address & "," & shtnm & rng1.Offset(0, 3).Address & ",0),0))" > If .Cells(s2idx, 5).Value <> 0 Then > .Cells(s2idx, 1).FormulaArray = "=min(if(" & shtnm & rng1.Offset(0, 1).Address & "=" & shtnm & r2.Address & ",if(" & _ > shtnm & rng1.Offset(0, 2).Address & "=" & shtnm & r3.Address & "," & shtnm & rng1.Address & ")))" > .Cells(s2idx, 2).FormulaArray = "=max(if(" & shtnm & rng1.Offset(0, 1).Address & "=" & shtnm & r2.Address & ",if(" & _ > shtnm & rng1.Offset(0, 2).Address & "=" & shtnm & r3.Address & "," & shtnm & rng1.Address & ")))" > .Cells(s2idx, 3).Value = r2.Value > .Cells(s2idx, 4).Value = r3.Value > s2idx = s2idx + 1 > End If > Next > Next > End With >End Sub |
| ▼Hirofumi さん： Ｔｋです。どうもありがとうございました。 早速使用させていただきます。 これからもよろしくお願いします。 お礼まで・・・・。 >なんか、スッキリ纏まらなくて気に入らないけれど >こんなもんかな？ > >Public Sub AddUp() > > Dim i As Long > Dim j As Long > Dim vntData As Variant > Dim vntAdd(4) As Variant > Dim lngDataTop As Long > Dim lngDataEnd As Long > Dim lngListTop As Long > Dim lngListEnd As Long > Dim wksData As Worksheet > Dim wksAdd As Worksheet > > Set wksData = Worksheets("sheet1") > With wksData > lngDataTop = 2 > lngDataEnd = .Cells(65536, 1).End(xlUp).Row > End With > Set wksAdd = Worksheets("sheet2") > With wksAdd > lngListTop = 2 > lngListEnd = .Cells(65536, 1).End(xlUp).Row > End With > > 'Listを作成 > i = lngDataTop > With wksData.Cells(i, 1) > vntData = Range(.Offset(, 0), .Offset(, 3)).Value > End With > vntAdd(0) = vntData(1, 1) > For j = 1 To 4 > vntAdd(j) = vntData(1, j) > Next j > i = i + 1 > 'データの最終まで繰り返し > Do Until i > lngDataEnd > With wksData.Cells(i, 1) > vntData = Range(.Offset(, 0), .Offset(, 3)).Value > End With > 'もし、データの品名、色が集計配列のそれと同じなら > If vntData(1, 2) = vntAdd(2) _ > And vntData(1, 3) = vntAdd(3) Then > '集計配列の２番に日付を代入 > vntAdd(1) = vntData(1, 1) > '集計配列の４番にデータの金額を加算 > vntAdd(4) = vntAdd(4) + vntData(1, 4) > Else > '集計シートの最終行を更新 > lngListEnd = lngListEnd + 1 > With wksAdd.Cells(lngListEnd, 1) > '書き込み行のA、B列の書式を文字に設定 > Range(.Offset(, 0), .Offset(, 1)).NumberFormatLocal = "@" > '書き込み行に集計配列を代入 > Range(.Offset(, 0), .Offset(, 4)).Value = vntAdd > End With > vntAdd(0) = vntData(1, 1) > For j = 1 To 4 > vntAdd(j) = vntData(1, j) > Next j > End If > 'データ用カウンタを更新 > i = i + 1 > Loop > lngListEnd = lngListEnd + 1 > With wksAdd.Cells(lngListEnd, 1) > '書き込み行のA、B列の書式を文字に設定 > Range(.Offset(, 0), .Offset(, 1)).NumberFormatLocal = "@" > '書き込み行に集計配列を代入 > Range(.Offset(, 0), .Offset(, 4)).Value = vntAdd > End With > > Set wksData = Nothing > Set wksAdd = Nothing > >End Sub |
| おはようございます。 Hirofumiさん、ichinoseさん、フォロー誠にありがとうございました。 ichinoseさん、毎回毎回ほんまに助かります。 次回のヘルプコール（多分あると思います。）の時も、よろしくよろしくです。 |
| #しかもベタロジックです。^^; 少ないステップ数ですのでご参考まで。 上から参照していき品名と色が異なれば開始日、終了日、総計金額を表示します。 With Worksheets(1).UsedRange LastRow = .Rows(.Rows.Count).Row End With With Worksheets(1) 日付 = "": 品名 = "": 色 = "": 総計金額 = 0 j = 2 For i = 2 To LastRow If 日付 = "" Then 開始日 = .Cells(i, 1) 日付 = .Cells(i, 1) 品名 = .Cells(i, 2) 色 = .Cells(i, 3) 総計金額 = 0 End If If .Cells(i + 1, 2) = 品名 And .Cells(i + 1, 3) = 色 Then 総計金額 = 総計金額 + .Cells(i, 4) Else Cells(j, 1) = 開始日 Cells(j, 2) = .Cells(i, 1) Cells(j, 3) = 品名 Cells(j, 4) = 色 Cells(j, 5) = 総計金額 + .Cells(i, 4) 日付 = "" j = j + 1 'sheet2の行カウンタ1UP End If Next End With |