商品コード一覧表をエクセルＶＢＡで作成

商品コード一覧表をＶＢＡ「エクセル2003」で作成したいのです。

２年ほど前に、このサイトで助けていただいたものです。

http://oshiete.goo.ne.jp/qa/7578507.html

↑前回のものを利用していたのですが、今回、改良を加えていただいたいのです。

改良点は２つです。

１）６面を１２面に増やす。

２）重複の少ないもから優先して抽出できるように（当面は400個の予定）


（問題点）

現在は６面のうち５面が同じになってしまう時もあります。

できる限り、重複しないものから優先的に並べられるようにしたいと思っております。

どうかよろしくお願いいたします。

No.1 回答者： watabe007 回答日時： 2014/04/27 12:32

Range("A1")にファイル名（Sheet1のA1セル）

Range("B1")に商品数（Sheet1のB1セル）
・エクセルシートのＡ列に、たてに4×12個を入力
　セル（　Ａ３～　Ａ６）にＡ面の色コード
　セル（　Ａ８～Ａ１１）にＢ面の色コード
　セル（Ａ１３～Ａ１６）にＣ面の色コード
　セル（Ａ１８～Ａ２１）にＤ面の色コード
　セル（Ａ２３～Ａ２６）にＥ面の色コード
　セル（Ａ２８～Ａ３１）にＦ面の色コード
　セル（Ａ３３～Ａ３６）にG面の色コード
　セル（Ａ３８～Ａ４１）にＨ面の色コード
　セル（Ａ４３～Ａ４６）にＩ面の色コード
　セル（Ａ４８～Ａ５１）にＪ面の色コード
　セル（Ａ５３～Ａ５６）にＫ面の色コード
　セル（Ａ５８～Ａ６１）にＬ面の色コード

と、しています。
CSVファイルはデスクトップに出力します。
Sub Test()
　　Dim ColData As Variant, fName As String
　　Dim myStr As String, myPath As String
　　Dim v(), i As Long, j As Long

　　fName = Range("A1").Value
　　ReDim v(1 To Range("B1").Value)
　　ColData = Range("A3:A61").Value
　　For i = 1 To UBound(v)
　　　　Do
　　　　　　myStr = コード作成(ColData)
　　　　　　For j = 1 To i
　　　　　　　　If v(j) = myStr Then myFlg = True
　　　　　　Next
　　　　　　If myFlg <> True Then
　　　　　　　　v(i) = myStr
　　　　　　　　Exit Do
　　　　　　End If
　　　　　　myFlg = False
　　　　Loop
　　Next
　　myPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
　　Open myPath & fName & ".csv" For Output As #1
　　For i = 1 To UBound(v)
　　　　Write #1, fName, v(i)
　　Next i
　　Close #1
　　MsgBox "完了!!", 64
End Sub
Function コード作成(ColData As Variant) As String
　　Dim ColCD As String
　　Dim i As Long, j As Long, k As Long
　　Dim n As Long

　　Randomize
　　For i = 1 To 12
　　　　n = Int(Rnd() * 4) + 1
　　　　j = (i - 1) * 5
　　　　ColCD = ColCD & ColData(n + j, 1)
　　Next
　　コード作成 = ColCD
End Function

この回答へのお礼

ありがとうございます。早速作動させてみました。
すると「インデックスが有効範囲にありません。」というエラー表示がでました。
また、大変申し訳ないのですが、商品数の指定をシート上ではなく、ＶＢＡのプログラムの中で指定してしますことができますでしょうか。
よろしくお願いいたします。

お礼日時：2014/04/27 18:09

No.2 回答者： 30246kiku 回答日時： 2014/04/27 12:55

Sheet2 を作るまでですが、以下でどうなりますか

Public Sub test()
　　Dim nTotal As Long
　　Dim sFileName As String
　　Dim vAry As Variant, vSub As Variant
　　Dim dic As Object, dicW As Object
　　Dim v As Variant, vW As Variant
　　Dim sS As String
　　Dim i As Long

　　With Worksheets("Sheet1")
　　　　nTotal = .Range("B1") '←商品数（Sheet1のB1セル）
　　　　sFileName = .Range("A1") '←ファイル名（Sheet1のA1セル）

　　　　vAry = Array("A3:A6", "A7:A10", "A11:A14", "A15:A18", _
　　　　　　　　　　"A19:A22", "A23:A26", "A27:A30", "A31:A34", _
　　　　　　　　　　"A35:A38", "A39:A42", "A43:A46", "A47:A52")

　　　　ReDim vSub(UBound(vAry))
　　　　For i = 0 To UBound(vSub)
　　　　　　vSub(i) = .Range(vAry(i))
　　　　Next
　　End With

　　Randomize

　　Set dic = CreateObject("Scripting.Dictionary")
　　Set dicW = CreateObject("Scripting.Dictionary")
　　While (dic.Count < nTotal)
　　　　sS = ""
　　　　dicW.RemoveAll
　　　　For Each v In vSub
　　　　　　vW = v(Int(UBound(v) * Rnd()) + 1, 1)
　　　　　　dicW(vW) = Null
　　　　　　sS = sS & vW
　　　　Next
　　　　If (dicW.Count > (UBound(vSub) + 1) \ 2) Then dic(sS) = Null
　　Wend
　　Set dicW = Nothing

　　With Worksheets("Sheet2")
　　　　.Cells.ClearContents
　　　　.Range("B1").Resize(dic.Count) = WorksheetFunction.Transpose(dic.Keys)
　　　　.Range("B1:B" & dic.Count).Sort Key1:=.Range("B1")
　　　　.Range("A1").Resize(dic.Count) = sFileName
　　End With

　　Set dic = Nothing
End Sub


概略説明

> 　　 vAry = Array("A3:A6", "A7:A10", "A11:A14", "A15:A18", _
部分では、各面の色を扱う範囲を指定しておきます
（同一列で："A3:B4" とかは ＮＧ）
記述した分が面数になります（上記では１２個記述しているので１２面）
また、上記では各色４つで記述していますが、ある面は６色・・・でも構いません

dic は出来上がった商品コードを重複なしで格納していきます
> 　　While (dic.Count < nTotal)
で、必要数になるまで繰り返します

dicW では、商品コードを作っていく間、使用した色を重複なしで格納していきます
各色の抽出は、
>　　　　　　vW = v(Int(UBound(v) * Rnd()) + 1, 1)
と、乱数で各面の色を扱う範囲から色を選びます

各面がどのように接しているかわからないので、以下単純に
>　　　　If (dicW.Count > (UBound(vSub) + 1) \ 2) Then dic(sS) = Null
で、商品コードを作った時の色数が、必要面数の半分より上なら商品コードとして格納します
（６面なら > 3 の判別になるので、色が２つなら商品コードとして格納しません）
（１２面なら > 6 ）
この辺りは調整してください

できあがったら、商品コードを Sheet2 の B 列に設定してソートします
A 列に、ファイル名を設定して　Sheet2 が出来上がります


※　１２面の時、> 10 とかすると、色の設定状況にもよりますが、
商品コードが作られにくい状況になり、無駄にループ回数が多くなるかもしれません
最悪、無限ループとかに陥るかもしれません

※ 確認される時には、商品数を 10 とか小さいものからにしてください

この回答へのお礼

ありがとうございます。早速作動させてみました。
すると「型が一致しません。」というエラー表示がでました。
シート１のＡ列に入力するデータは「文字列」になります。
説明不足でした。
申し訳ございません。

お礼日時：2014/04/27 17:59

No.3 回答者： watabe007 回答日時： 2014/04/27 18:49

>すると「インデックスが有効範囲にありません。

」というエラー表示がでました。
どの箇所で出たのか説明がないと今後、回答しかねます。
Sub Test()
　　Dim ColData As Variant, fName As String
　　Dim myStr As String, myPath As String
　　Dim v(), i As Long, j As Long
　　Dim myFlg As Boolean, kazu As Long

　　kazu = Val(InputBox("商品数を入力して下さい。", "商品数入力"))
　　If kazu = 0 Then
　　　　MsgBox "キャンセルもしくは、数字以外を入力されました。"
　　　　Exit Sub
　　End If
　　fName = Range("A1").Value
　　ReDim v(1 To kazu)
　　ColData = Range("A3:A61").Value
　　For i = 1 To kazu
　　　　Do
　　　　　　myStr = コード作成(ColData)
　　　　　　For j = 1 To i
　　　　　　　　If v(j) = myStr Then myFlg = True
　　　　　　Next
　　　　　　If myFlg <> True Then
　　　　　　　　v(i) = myStr
　　　　　　　　Exit Do
　　　　　　End If
　　　　　　myFlg = False
　　　　Loop
　　Next
　　myPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
　　Open myPath & fName & ".csv" For Output As #1
　　For i = 1 To UBound(v)
　　　　Write #1, fName, v(i)
　　Next i
　　Close #1
　　MsgBox "完了!!", 64
End Sub
Function コード作成(ColData As Variant) As String
　　Dim ColCD As String
　　Dim i As Long, j As Long, k As Long
　　Dim n As Long

　　Randomize
　　For i = 1 To 12
　　　　n = Int(Rnd() * 4) + 1
　　　　j = (i - 1) * 5
　　　　ColCD = ColCD & ColData(n + j, 1)
　　Next
　　コード作成 = ColCD
End Function

この回答へのお礼

迅速な回答をいただきましてありがとうございます。
次の２点のことを可能にできますでしょうか。
（１）
できる限り、重複している色が少ないコードを作りたいと思っています。たとえば、作成する数を1,000個、その中から重複の割合が少ないものから順に400個抽出する。
最初にメッセージボックスで「作成数」と「抽出数」を入力してから作成する。
（２）
最後にCSVファイルで保存する時にメッセージボックスでファイル名を入力できるようにする。

どうかよろしくお願いいたします。

お礼日時：2014/04/27 23:35

No.4 回答者： 30246kiku 回答日時： 2014/04/28 00:26

＃２です

> 「型が一致しません。」というエラー表示がでました。

これだけでは何も特定・想定できません
どの様なデータで、どの様な範囲指定して、どこでエラーになったのか提示してください。

最低限確認した内容を提示しておくと

A3～A6 に、A1, A2, A3, A4
A7～A10 に、B1, B2, B3, B4
A1 に、ABCDEFG、B1 に 400

Array 設定部分を、奇数面、偶数面に以下の様な同じ範囲を指定

　　　　vAry = Array("A3:A6", "A7:A10", "A3:A6", "A7:A10", _
　　　　　　　　　　"A3:A6", "A7:A10", "A3:A6", "A7:A10", _
　　　　　　　　　　"A3:A6", "A7:A10", "A3:A6", "A7:A10")

この指定で、エラーなく動作しており、エラーを想定する事が出来ません
具体的な環境・設定の提示をお願いします。


＃２の記述において、
> 現在は６面のうち５面が同じになってしまう時もあります。
の解釈に間違いがあったかもしれません

過去QAでの例では、各色は異なる名称になっているようでしたが、
「６面のうち５面が同じ」ということは、同じ色が含まれた範囲指定なのか・・・
というものを想定したものになっていました。

なので、色の数で判別するという単純なものにしてました。


視点を変えて、同じ見え方・・・・を考えてみるに（面の配置を考慮）
例えば、１色で２か所を塗る・・・・
６面の場合、
サイコロ（天井：１、右：２、上：３、左：５、下：４、底：６）で考えてみると

１－２、１－３、１－５・・・　１２通りは、転がれば同じもの
１－６、２－５、３－４　の３通りも転がれば同じもの

このような同じものは排除したい・・・・ってなことだったのでしょうか
２色の、また３色の・・・場合のパターンを羅列するのもしんどいので
何色になるのかわからないけど、６箇所のパターンをチェックしましょう・・・というのが今回

天井：１、底：６とした場合、
（2，3，5，4）（3，5，4，2）（5，4，2，3）（4，2，3，5）の順４つは転がれば同じでしょう
また、天井：２、底：５とした場合、
（1，4，6，3）（4，6，3，1）（6，3，1，4）（3，1，4，6）の順４つは転がれば同じでしょう
同様に、天井：３・・・・

VBA での記述では、

　　　　vCary = Array( _
　　　　　　　　　　Array(1, Array(2, 3, 5, 4), 6), _
　　　　　　　　　　Array(2, Array(1, 4, 6, 3), 5), _
　　　　　　　　　　Array(3, Array(1, 2, 6, 5), 4), _
　　　　　　　　　　Array(4, Array(1, 5, 6, 2), 3), _
　　　　　　　　　　Array(5, Array(1, 3, 6, 4), 2), _
　　　　　　　　　　Array(6, Array(2, 4, 5, 3), 1) _
　　　　　　　　)

とする事に、
各面の色を乱数で抽出しておいて、
　　　　　　　　　　Array(1, Array(2, 3, 5, 4), 6), _
の場合、（1,2,3,5,4,6）（1,3,5,4,2,6）（1,5,4,2,3,6）（1,4,2,3,5,6）
の４通りの順で商品コードを生成し、既に求めていたものかをチェック
これを
　　　　　　　　　　Array(6, Array(2, 4, 5, 3), 1) _
まで繰り返します。
最終的に生成していなかった商品コードだったら、格納していくように・・・

これは、６面での例になる？と思うので、１２面の場合は応用してみてください
色数の判別だけであれば、＃２のもので容易に何面でも・・・


Public Sub test2()
　　Dim nTotal As Long
　　Dim sFileName As String
　　Dim vAry As Variant, vSub As Variant
　　Dim vCary As Variant, vC As Variant
　　Dim dic As Object
　　Dim v As Variant, vW As Variant, vv As Variant
　　Dim sS As String
　　Dim i As Long
　　Dim iEcnt As Long

　　With Worksheets("Sheet1")
　　　　nTotal = .Range("B1") '←商品数（Sheet1のB1セル）
　　　　sFileName = .Range("A1") '←ファイル名（Sheet1のA1セル）

　　　　vAry = Array("A3:A6", "A7:A10", "A3:A6", "A7:A10", _
　　　　　　　　　　"A3:A6", "A7:A10")
　　　　vCary = Array( _
　　　　　　　　　　Array(1, Array(2, 3, 5, 4), 6), _
　　　　　　　　　　Array(2, Array(1, 4, 6, 3), 5), _
　　　　　　　　　　Array(3, Array(1, 2, 6, 5), 4), _
　　　　　　　　　　Array(4, Array(1, 5, 6, 2), 3), _
　　　　　　　　　　Array(5, Array(1, 3, 6, 4), 2), _
　　　　　　　　　　Array(6, Array(2, 4, 5, 3), 1) _
　　　　　　　　)

　　　　ReDim vSub(UBound(vAry))
　　　　ReDim vC(UBound(vAry))
　　　　For i = 0 To UBound(vSub)
　　　　　　vSub(i) = .Range(vAry(i))
　　　　Next
　　End With

　　Randomize

　　Set dic = CreateObject("Scripting.Dictionary")
　　iEcnt = 0
　　Do While ((dic.Count < nTotal) And (iEcnt < 10000))
　　　　For i = 0 To UBound(vSub)
　　　　　　vC(i) = vSub(i)(Int(UBound(vSub(i)) * Rnd()) + 1, 1)
　　　　Next
　　　　For Each v In vCary
　　　　　　For Each vW In AryOrder(v)
　　　　　　　　sS = ""
　　　　　　　　For Each vv In vW
　　　　　　　　　　sS = sS & vC(vv - 1)
　　　　　　　　Next
　　　　　　　　If (dic.Exists(sS)) Then Exit For
　　　　　　Next
　　　　　　If (Not IsEmpty(vW)) Then Exit For
　　　　Next
　　　　If (IsEmpty(vW)) Then dic(Join(vC, "")) = Null
　　　　iEcnt = iEcnt + 1
　　Loop
　　Debug.Print iEcnt

　　With Worksheets("Sheet2")
　　　　.Cells.ClearContents
　　　　.Range("B1").Resize(dic.Count) = WorksheetFunction.Transpose(dic.Keys)
　　　　.Range("B1:B" & dic.Count).Sort Key1:=.Range("B1")
　　　　.Range("A1").Resize(dic.Count) = sFileName
　　End With

　　Set dic = Nothing
End Sub

Private Function AryOrder(vSrc As Variant) As Variant
　　Dim vAry As Variant, vS As Variant
　　Dim i As Long, j As Long, iPos As Long

　　ReDim vS(UBound(vSrc) + UBound(vSrc(1)))
　　ReDim vAry(UBound(vSrc(1)))
　　For i = 0 To UBound(vAry)
　　　　vS(0) = vSrc(0)
　　　　j = i
　　　　iPos = 1
　　　　While (iPos <= UBound(vSrc(1)) + 1)
　　　　　　vS(iPos) = vSrc(1)(j)
　　　　　　j = j + 1
　　　　　　If (j > UBound(vSrc(1))) Then j = 0
　　　　　　iPos = iPos + 1
　　　　Wend
　　　　vS(iPos) = vSrc(2)
　　　　vAry(i) = vS
　　Next
　　AryOrder = vAry
End Function

この回答へのお礼

ありがとうございます。
♯５のお礼の欄の記述に対する
返信をお待ちしております。

お礼日時：2014/04/30 20:47

No.5 回答者： 30246kiku 回答日時： 2014/04/29 04:07

＃４です

> 現在は６面のうち５面が同じになってしまう時もあります。
の解釈に間違いがあったと思います。

色の重複と思っていましたが、１面以外の色パターンが同じなんですよね
１２面の時には、何面分で重複とみなすんでしょうか。
重複の排除は別のアプローチになると思います。

失礼しました

この回答へのお礼

お世話になっております。以下、回答いたします。

１２面文のコードを作成するには、

Ａ面はＡ１～Ａ４の４色から１つを選択
Ｂ面はＢ１～Ｂ４の４色から１つを選択
Ｃ面はＣ１～Ｃ４の４色から１つを選択
・
・
Ｌ面はＬ１～Ｌ４の４色から１つを選択

それぞれ選択した１２個の色コードを１行に横に並べたものが商品コードです。

例えば、

１）Ａ１Ｂ１Ｃ１Ｄ１Ｅ１Ｆ１Ｇ１Ｈ１Ｉ１Ｊ１Ｋ１Ｌ１

２）Ａ１Ｂ２Ｃ１Ｄ２Ｅ１Ｆ２Ｇ１Ｈ２Ｉ１Ｊ２Ｋ１Ｌ２

３）Ａ１Ｂ２Ｃ３Ｄ４Ｅ１Ｆ２Ｇ３Ｈ４Ｉ１Ｊ２Ｋ３Ｌ４

このような商品コードになります。

重複の度合いを見てみると・・・

１）と２）では、６個の重複があります。
（具体的には、Ａ１、Ｃ１、Ｅ１、Ｇ１、Ｉ１、Ｋ１の６個）

１）と３）では、３個の重複があります。
（具体的には、Ａ１、Ｅ１、Ｉ１の３個）

２）と３）では、６個の重複があります。
（具体的には、Ａ１、Ｂ２、Ｅ１、Ｆ２、Ｉ１、Ｊ２の６個）


以前のプログラムでは、以下のように１２個のうち１１個までが重複している場合もありました。

１）Ａ１Ｂ１Ｃ１Ｄ１Ｅ１Ｆ１Ｇ１Ｈ１Ｉ１Ｊ１Ｋ１Ｌ１
２）Ａ２Ｂ１Ｃ１Ｄ１Ｅ１Ｆ１Ｇ１Ｈ１Ｉ１Ｊ１Ｋ１Ｌ１

　　↑１面目のＡ１とＡ２以外はすべて同じになっています。



> １２面の時には、何面分で重複とみなすんでしょうか。
> 重複の排除は別のアプローチになると思います。


ここから、上のご質問の回答になりますが・・・

重複とみなさないとするのは「○面」という決まったものは無いのですが、

出来る限り、重複の少ないものを４００個作成したいと考えております。

素人考えですが、

2,000とか3,000と多めに作って、重複の少ない順に400個を選び出す。

というような方法はできますでしょうか。



「追記」

♯4のプログラムは問題なく動作いたしました。大変ありがとうございました。

しかし、１つ１つの色コードが２文字３文字程度であれば問題なく動作するのですが、

色コードの文字数を５０文字とか６０文字にすると、「型が一致しません。」というメッセージが表示されません。

エラーメッセージのウィンドウが出るだけで、どの行がエラーなのか表記がどこにも出ていません。


「用いたデータ」

商品コード　　400

色コードＡ１色コードＡ２色コードＡ３色コードＡ４色コードＡ５色コードＡ６色コードＡ７色コードＡ８色コードＡ９
色コードＢ１色コードＢ２色コードＢ３色コードＢ４色コードＢ５色コードＢ６色コードＢ７色コードＢ８色コードＢ９
色コードＣ１色コードＣ２色コードＣ３色コードＣ４色コードＣ５色コードＣ６色コードＣ７色コードＣ８色コードＣ９
　・
　・
　・
色コードＪ１色コードＪ２色コードＪ３色コードＪ４色コードＪ５色コードＪ６色コードＪ７色コードＪ８色コードＪ９
色コードＫ１色コードＫ２色コードＫ３色コードＫ４色コードＫ５色コードＫ６色コードＫ７色コードＫ８色コードＫ９
色コードＬ１色コードＬ２色コードＬ３色コードＬ４色コードＬ５色コードＬ６色コードＬ７色コードＬ８色コードＬ９


「用いた範囲指定」

vAry = Array("A3:A6", "A7:A10", "A11:A14", "A15:A18", _
　　　　　　"A19:A22", "A23:A26", "A27:A30", "A31:A34", _
　　　　　　"A35:A38", "A39:A42", "A43:A46", "A47:A50"）


上記の色コードで作成すると、できるであろう商品コードは、５４文字×１２面＝６４８文字となります。
最大でこの位のコードを作成できるようにしたいのですが、不可能なのでしょうか。
（２年前にご教示いただいたプログラムでは、６００～８００文字でも動作しております。）

お礼日時：2014/04/29 22:10

No.6 回答者： ki-aaa 回答日時： 2014/05/01 07:56

これでどうかな

Sub TestMyXXX()
Dim i As Long, j As Long
Dim myDic As Object, myDicKey
Dim myArray(1 To 12) As String
Dim myTemp As String
Dim sFileName As String

Set myDic = CreateObject("Scripting.Dictionary")

Do While myDic.Count < 400
Do
For i = 1 To 12
myArray(i) = Chr(64 + i) & Int(Rnd() * 4) + 1
Next i
myTemp = Join(myArray, "")
'同じ数字が、6個以上あればやり直し
'24(myTempの文字数)-6 < 19
If Len(Replace(myTemp, "1", "")) < 19 Then
ElseIf Len(Replace(myTemp, "2", "")) < 19 Then
ElseIf Len(Replace(myTemp, "3", "")) < 19 Then
ElseIf Len(Replace(myTemp, "4", "")) < 19 Then
'同じ組み合わせが、以前にあればやり直し
ElseIf myDic.exists(myTemp) Then
Else
myDic(myTemp) = myTemp
Exit Do
End If
Loop
Loop

myDicKey = myDic.keys
With Sheets("Sheet1")
.Cells.ClearContents
.Cells(1, 1).Resize(myDic.Count) = WorksheetFunction.Transpose(myDicKey)
.Copy
End With
sFileName = "Tset" & Format(Now, "yyyymmddhhmmss")
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & sFileName, FileFormat:=xlCSV
ActiveWindow.Close (False)

Set myDic = Nothing
End Sub

No.7 回答者： 30246kiku 回答日時： 2014/05/01 20:58

＃５です

回答付けようか迷ったのですが・・・
コードだけでも、文字数制限に引っ掛かる様で・・・

ここに回答を記述できないので、ブログの方に記事としてあげました。

自身のブログのURL/キーワードの提示は規約によりできませんので、探してみてください。
辿ってみたりいろいろと・・・・

失礼しました

この回答へのお礼

いろいろとありがとうございました。
ブログを探しに参ります。

お礼日時：2014/05/02 13:57