こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

締切り済みの質問

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

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

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

http://okwave.jp/qa/q7578507.html

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

改良点は2つです。

1)6面を12面に増やす。

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


(問題点)

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

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

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

投稿日時 - 2014-04-26 16:37:04

QNo.8569708

すぐに回答ほしいです

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(7)

ANo.7

#5です

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

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

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

失礼しました

投稿日時 - 2014-05-01 20:58:40

お礼

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

投稿日時 - 2014-05-02 13:57:41

ANo.6

これでどうかな

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

投稿日時 - 2014-05-01 07:56:10

ANo.5

#4です

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

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

失礼しました

投稿日時 - 2014-04-29 04:07:27

お礼

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

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

A面はA1~A4の4色から1つを選択
B面はB1~B4の4色から1つを選択
C面はC1~C4の4色から1つを選択


L面はL1~L4の4色から1つを選択

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

例えば、

1)A1B1C1D1E1F1G1H1I1J1K1L1

2)A1B2C1D2E1F2G1H2I1J2K1L2

3)A1B2C3D4E1F2G3H4I1J2K3L4

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

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

1)と2)では、6個の重複があります。
(具体的には、A1、C1、E1、G1、I1、K1の6個)

1)と3)では、3個の重複があります。
(具体的には、A1、E1、I1の3個)

2)と3)では、6個の重複があります。
(具体的には、A1、B2、E1、F2、I1、J2の6個)


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

1)A1B1C1D1E1F1G1H1I1J1K1L1
2)A2B1C1D1E1F1G1H1I1J1K1L1

  ↑1面目のA1とA2以外はすべて同じになっています。



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


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

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

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

素人考えですが、

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

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



「追記」

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

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

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

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


「用いたデータ」

商品コード  400

色コードA1色コードA2色コードA3色コードA4色コードA5色コードA6色コードA7色コードA8色コードA9
色コードB1色コードB2色コードB3色コードB4色コードB5色コードB6色コードB7色コードB8色コードB9
色コードC1色コードC2色コードC3色コードC4色コードC5色コードC6色コードC7色コードC8色コードC9
 ・
 ・
 ・
色コードJ1色コードJ2色コードJ3色コードJ4色コードJ5色コードJ6色コードJ7色コードJ8色コードJ9
色コードK1色コードK2色コードK3色コードK4色コードK5色コードK6色コードK7色コードK8色コードK9
色コードL1色コードL2色コードL3色コードL4色コードL5色コードL6色コードL7色コードL8色コードL9


「用いた範囲指定」

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")


上記の色コードで作成すると、できるであろう商品コードは、54文字×12面=648文字となります。
最大でこの位のコードを作成できるようにしたいのですが、不可能なのでしょうか。
(2年前にご教示いただいたプログラムでは、600~800文字でも動作しております。)

投稿日時 - 2014-04-29 22:10:53

ANo.4

#2です

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

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

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

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")

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


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

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

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


視点を変えて、同じ見え方・・・・を考えてみるに(面の配置を考慮)
例えば、1色で2か所を塗る・・・・
6面の場合、
サイコロ(天井:1、右:2、上:3、左:5、下:4、底:6)で考えてみると

1-2、1-3、1-5・・・ 12通りは、転がれば同じもの
1-6、2-5、3-4 の3通りも転がれば同じもの

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

天井:1、底:6とした場合、
(2,3,5,4)(3,5,4,2)(5,4,2,3)(4,2,3,5)の順4つは転がれば同じでしょう
また、天井:2、底:5とした場合、
(1,4,6,3)(4,6,3,1)(6,3,1,4)(3,1,4,6)の順4つは転がれば同じでしょう
同様に、天井:3・・・・

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)
の4通りの順で商品コードを生成し、既に求めていたものかをチェック
これを
          Array(6, Array(2, 4, 5, 3), 1) _
まで繰り返します。
最終的に生成していなかった商品コードだったら、格納していくように・・・

これは、6面での例になる?と思うので、12面の場合は応用してみてください
色数の判別だけであれば、#2のもので容易に何面でも・・・


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-28 00:26:11

お礼

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

投稿日時 - 2014-04-30 20:47:15

ANo.3

>すると「インデックスが有効範囲にありません。」というエラー表示がでました。
どの箇所で出たのか説明がないと今後、回答しかねます。
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

投稿日時 - 2014-04-27 18:49:56

お礼

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

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

投稿日時 - 2014-04-27 23:35:56

ANo.2

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" とかは NG)
記述した分が面数になります(上記では12個記述しているので12面)
また、上記では各色4つで記述していますが、ある面は6色・・・でも構いません

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
で、商品コードを作った時の色数が、必要面数の半分より上なら商品コードとして格納します
(6面なら > 3 の判別になるので、色が2つなら商品コードとして格納しません)
(12面なら > 6 )
この辺りは調整してください

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


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

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

投稿日時 - 2014-04-27 12:55:48

お礼

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

投稿日時 - 2014-04-27 17:59:01

ANo.1

Range("A1")にファイル名(Sheet1のA1セル)
Range("B1")に商品数(Sheet1のB1セル)
・エクセルシートのA列に、たてに4×12個を入力
 セル( A3~ A6)にA面の色コード
 セル( A8~A11)にB面の色コード
 セル(A13~A16)にC面の色コード
 セル(A18~A21)にD面の色コード
 セル(A23~A26)にE面の色コード
 セル(A28~A31)にF面の色コード
 セル(A33~A36)にG面の色コード
 セル(A38~A41)にH面の色コード
 セル(A43~A46)にI面の色コード
 セル(A48~A51)にJ面の色コード
 セル(A53~A56)にK面の色コード
 セル(A58~A61)にL面の色コード

と、しています。
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 12:32:28

お礼

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

投稿日時 - 2014-04-27 18:09:56

あなたにオススメの質問