[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『重複なしデータを1ヶ月分抽出したい』（sachi）
度々お世話になります。 以前こちらで教えて頂いたDictionaryを使って重複なしのデータを抽出しようと思った のですが、応用がきかず途中で行き詰ってしまいました。 どなたか教えて下さい。よろしくお願い致します。
シート1 ↓結合セル [G] [H] [I,J] [K,L] [M:Q] [AC][AD][AE,AF][AG,AH][AI:AM]… [7] 種別 購入品 種別 購入品 [8] 果物 バナナ 野菜 大根 [9] 果物 桃 魚 さんま [10] 野菜 にんじん 野菜 ねぎ [11] 魚 鮭 果物 りんご [12] 野菜 にんじん 野菜 大根 [13] 果物 桃 [14] [15] [16] [17]
シート2 [B] [C] [D] [2] 果物 野菜 魚 [3] バナナ,桃 にんじん 鮭 [4] りんご 大根,ねぎ さんま
上記のようにシート1の種別と購入品をキーに重複なしのデータを1日分ずつ抽出して シート2に種別ごとに文字列を結合して転記したい。 データは11列おきに月曜から始まって日曜まで、3行おきに10行分の欄が5週分設けて あります。日によって購入件数は違います。
とりあえず1週分のデータを抽出してみようと思ったのですが、下記のコードだと 1週分のデータから重複を削除してしまうため、1日ずつのデータが抽出できません。 それから翌週以降のデータの抽出と文字列の結合をさせるためのコードがわからず、 困っています。（文字列の結合は出来たらでいいです） 中途半端で申し訳ありませんが、よろしくお願いします。
Sub test()
Dim MyDic(1 To 3) As Object
Dim i As Long, j As Long
Dim buf As String, Keys
Dim tbl As Variant
For i = 1 To 3
Set MyDic(i) = CreateObject("Scripting.Dictionary")
Next i
For i = 7 To 149 Step 11
With Worksheets("シート1")
tbl = .Range(.Cells(8, i), .Cells(17, i + 6)).Value
End With
For j = 1 To UBound(tbl)
buf = tbl(j, 1) & vbTab & tbl(j, 7)
Select Case tbl(j, 1)
Case "果物"
If Not MyDic(1).Exists(buf) Then
MyDic(1).Add buf, Application.Index(tbl, j, 7)
End If
Case "野菜"
If Not MyDic(2).Exists(buf) Then
MyDic(2).Add buf, Application.Index(tbl, j, 7)
End If
Case "魚"
If Not MyDic(3).Exists(buf) Then
MyDic(3).Add buf, Application.Index(tbl, j, 7)
End If
End Select
Next j
Next i
If MyDic(1).Count > 0 Then
With Worksheets("シート2")
.Range("B3").Resize(MyDic(1).Count, 1).Value = Application.Transpose(MyDic(1).Items)
End With
End If
If MyDic(2).Count > 0 Then
With Worksheets("シート2")
.Range("C3").Resize(MyDic(2).Count, 1).Value = Application.Transpose(MyDic(2).Items)
End With
End If
If MyDic(3).Count > 0 Then
With Worksheets("シート2")
.Range("D3").Resize(MyDic(3).Count, 1).Value = Application.Transpose(MyDic(3).Items)
End With
End If
End Sub
Excel2000 Windows
こんばんは
>データは11列おきに月曜から始まって日曜まで
ということで、
[G]列〜 月曜日
[R]列〜 火曜日
[AC]列〜 水曜日
[AN]列〜 木曜日
[AY]列〜 金曜日
[BJ]列〜 土曜日
[BU]列〜 日曜日
と想定し、
(↑ 11列づつでないときは Set c = c.Offset(, 11) のところの
修正が必要です)
> とりあえず1週分のデータを抽出 してみました。
Sub Try_1週分()
Dim ans() As String
Dim v
Dim i As Long, j As Long, m As Long
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Dim c As Range
ReDim ans(0 To 7, 1 To 3)
dic("果物") = 1
dic("野菜") = 2
dic("魚") = 3
ans(0, 1) = "果物"
ans(0, 2) = "野菜"
ans(0, 3) = "魚"
Set c = Worksheets(1).[G7]
For m = 1 To 7 '月曜から 日曜まで
v = c.Offset(1).Resize(10, 7).Value
For i = 1 To 10 '上から下へ
If IsEmpty(v(i, 1)) Then Exit For '種別データが空白なら、この日のデータ終了
j = dic(v(i, 1))
If Len(ans(m, j)) Then
If InStr(ans(m, j), v(i, 7)) = 0 Then ' まだ購入品記載なかったら、
ans(m, j) = ans(m, j) & "," & v(i, 7)' 追加する
End If
Else
ans(m, j) = v(i, 7)
End If
Next
Set c = c.Offset(, 11)
Next
Set dic = Nothing
Worksheets(2).Range("B2").Resize(8, 3).Value = ans 'シート2に書き出す
End Sub
(kanabun)
あと、 >3行おきに10行分の欄が5週分 ということですけど、列見出しも考慮すると、最初の見出し行が 7行目のとき 次の週は 21行目 ということですかね？ （下の例はそう考えて Offset(14) しています）
Sub Try2_5週分()
Dim ans() As String
Dim v
Dim i As Long, j As Long, m As Long, n As Long, k As Long
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Dim c0 As Range, c As Range
ReDim ans(0 To 35, 1 To 3)
dic("果物") = 1
dic("野菜") = 2
dic("魚") = 3
ans(0, 1) = "果物"
ans(0, 2) = "野菜"
ans(0, 3) = "魚"
Set c0 = Worksheets(1).[G7]
Set c = c0
For n = 1 To 5 '1週目から ５週目まで
For m = 1 To 7 '月曜日から 日曜日まで
If IsEmpty(c.Offset(1)) Then Exit For
k = (n - 1) * 7 + m
v = c.Offset(1).Resize(10, 7).Value
For i = 1 To 10
If IsEmpty(v(i, 1)) Then Exit For
j = dic(v(i, 1))
If Len(ans(k, j)) Then
If InStr(ans(k, j), v(i, 7)) = 0 Then
ans(k, j) = ans(k, j) & "," & v(i, 7)
End If
Else
ans(k, j) = v(i, 7)
End If
Next
If m = 7 Then
Set c0 = c0.Offset(14)
Set c = c0
Else
Set c = c.Offset(, 11)
End If
Next m
Next n
Set dic = Nothing
With Worksheets(2)
.Columns("B:D").ClearContents
.Range("B2").Resize(k + 1, 3).Value = ans
End With
End Sub
(kanabun)
kanabun様
回答ありがとうございました。 列の11行おきというのはM列からのカウントでした。G列からだと22行おきになるので、ご指示通り 修正したらうまくいきました。 行については2週目は21行目が見出し行であっています。説明不足ですみません。
上記のコードで試してみたところ、1週目の土日がブランクの状態で、 2週目の月曜以降に種別と購入品が入力されている場合、1週目の金曜分までしか シート2に表示されませんでした。土日も入力するとそれ以降も表示されましたが、 次にまたブランクの日があるとその前日までしか表示されません。 ブランクの日の分はシート2の行を空けて、それ以降をまた表示させるには どうしたらいいでしょうか？
それから現在、上記のコードを勉強中なのですが、k = (n - 1) * 7 + mのところの意味を 教えて頂けないでしょうか？ 質問ばかりですみませんが、よろしくお願い致します。 (sachi)
こんばんは
> ブランクの日の分はシート2の行を空けて、それ以降をまた表示させるには > どうしたらいいでしょうか？
> If IsEmpty(c.Offset(1)) Then Exit For
のところを Exit For するのでなく、以下のように
If 空白でなかったら Then
処理
End If
のようにすれば、お望みの出力になるかと思います。
Set c0 = Worksheets(1).[G7]
Set c = c0
For n = 1 To 5 '1週目から ５週目まで
For m = 1 To 7 '月曜日から 日曜日まで
'If IsEmpty(c.Offset(1)) Then Exit For
If Not IsEmpty(c.Offset(1)) Then '◆変更
k = (n - 1) * 7 + m
v = c.Offset(1).Resize(10, 7).Value
For i = 1 To 10
If IsEmpty(v(i, 1)) Then Exit For
j = dic(v(i, 1))
If Len(ans(k, j)) Then
If InStr(ans(k, j), v(i, 7)) = 0 Then
ans(k, j) = ans(k, j) & "," & v(i, 7)
End If
Else
ans(k, j) = v(i, 7)
End If
Next
End If '◆追加
If m = 7 Then
Set c0 = c0.Offset(14)
Set c = c0
Else
Set c = c.Offset(, 11)
End If
Next m
Next n
> 上記のコードを勉強中なのですが、k = (n - 1) * 7 + mのところの意味を > 教えて頂けないでしょうか？
その式は、
For n = 1 To 5 '1週目から ５週目まで
For m = 1 To 7 '月曜日から 日曜日まで
ですから、たとえば (k = )
n = 1 (1週目) m = 1 (月曜日) のとき、 上の式は (1 - 1) *7 + m で 出力用配列の 1行目
n = 2 (2週目) m = 1 (月曜日) のとき、 上の式は (2 - 1) *7 + 1 で 出力用配列の 8行目
n = 5 (5週目) m = 1 (月曜日) のとき、 上の式は (5 - 1) *7 + 1 で 出力用配列の 29行目
と、出力用配列(35行+ヘッダ行 = 36行用意してあります) の書き込む行番号を計算しているところです。
(kanabun)
kanabun様
早速のご回答ありがとうございました！ 明朝、会社で試してみます。 丁寧な説明もありがとうございました、大変助かりました。
(sachi)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.