FC2ブログ

スポンサーサイト 


上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

Excel VBA をやってみた その10 Vol.2 


この記事は、「Excel VBA をやってみた その10」の続編です。
1度そちらを参照されてから読まれたらと思います。

内容としては、多面体に色を割付ける時、重複するパターンを少なく割付けていくには・・・・

その記事で、サンプルファイルに入れていなかったVBA記述等、今回のサンプルファイルに盛り込んでいます。
また、もう少し Excel 側の記述を確かめています。
その中には、
今まで「A」「B」~「L」の順で確認していたものを、順をローテーションさせた出力もしています。

kENt195_1.jpg  kENt195_2.jpg

条件付き書式で、パターンを探してみると「重複」とは何ぞや・・・・ が疑問になるかも・・・・・・
重複を減らす・・・・ 各面の色数を増やす方向のアプローチもありなのかなぁ??

今回のサンプルファイルには、Excel ファイル以外に Access ファイルも入れています。
前の記事で Access でやってみたら・・・・ に、触れていましたが、今回、何パターンか追加試行しています。

Access での動きとしては、
・同梱 Excel ファイルを開いて情報を入手
・色の割付け処理は Access のテーブル/SQL を使って
・結果を Excel ファイルに書き出す(情報を入手した Excel ファイルの Sheet2 へ)
・処理後、Excel ファイルを表示(保存するかは、操作者任せに・・・)

記事後半には、Excel での、また、Access での処理時間を Timer() で測定した結果を記述しています。
 
Excel 側での確認を進めます。
最後の方に記述していた「test444」を改造していきます。

「test444」では、与えられた面数を4つ・3つ単位でブロック化して、その中で全パターン展開・・・
その展開したものをブロック間で組み合わせていくというものでした。
やってみると、4つで、3つでブロック化した実行速度差はあまり無いようです。
そこで、ブロック化は3つ固定に・・・
    i = UBound(vSub) + 1
    For j = 4 To 2 Step -1
      If ((i Mod j) = 0) Then
        ReDim vChk(i \ j - 1)
        ReDim sChk(i \ j - 1)
        ReDim iChkHdn(i \ j - 1)
        ReDim vPos(j - 1)
        iAryEmt = j
        Exit For
      End If
    Next
    For i = 0 To UBound(vChk)
      v = Empty
      Call mkPtn(vSub, vPos, i, iAryEmt, i * iAryEmt, v)
      vChk(i) = v
    Next

  Const CBLK As Long = 3
・・・・
    i = UBound(vSub) + 1
    j = 0
    If ((i Mod CBLK) = 0) Then j = 1
    ReDim vChk(i \ CBLK - j)
    ReDim sChk(i \ CBLK - j)
    ReDim iChkHdn(i \ CBLK - j)
    iAryEmt = CBLK
    iNxtPos = 0
    For j = 0 To UBound(vChk)
      If ((i - iNxtPos) < iAryEmt) Then iAryEmt = i - iNxtPos
      ReDim vPos(iAryEmt - 1)
      v = Empty
      Call mkPtn(vSub, vPos, iAryEmt, iNxtPos, v)
      vChk(j) = v
      iNxtPos = iNxtPos + iAryEmt
    Next
ブロック化した面数で全パターンを求める関数「mkPtn」もそれなりに変更

また、求めたい数が全パターン数以上なら全パターン分返す処理部分を見直し
  If (j <= nTotal) Then
    If (i = 1) Then
      vDic = vChk(0)
    Else
      Exit Sub
    End If

  If (j <= nTotal) Then
    ReDim vPos(UBound(vSub))
    vDic = Empty
    Call mkPtn(vSub, vPos, UBound(vSub) + 1, 0, vDic)

後は、細かい部分を変更してます。
・各ブロックから抽出する際に、隠しておく数を乱数で求めてみる
・Dictionary からキーを得る部分の見直し

また、パターン確認用にするので「Sheet3」に対してパターン部分のみを書き出し
書き出したパターンは「A」から始まるものなので、
その横の列に、「B」から、「C」から・・・始まるパターンに変更し、各列でソートするように
  With Worksheets("Sheet3")
    .Cells.ClearContents
    With .Range("A1")
      For i = 0 To UBound(vDic)
        sS = ""
        v = Split(vDic(i), ",")
        For j = 0 To UBound(vSub)
          sS = sS & vSub(j)(v(j), 1)
        Next
        .Offset(i, 0) = sS
      Next
      With .Offset(0, 1).Resize(i, UBound(vSub)) ★ ローテーションパターンの展開
        .FormulaR1C1 = "=RIGHT(RC[-1]," & UBound(vSub) * 2 & ")&LEFT(RC[-1],2)"
        .Value = .Value
      End With
    End With
    For j = Asc("A") To Asc("A") + UBound(vSub) + 1 ★ 各列単位でのソート
      .Range(Chr(j) & "1:" & Chr(j) & i).Sort Key1:=.Range(Chr(j) & "1")
    Next
    .Columns.AutoFit
  End With

こんな感じで変更してみました。
今回色コードは「A1」とか「B3」の様に2文字なので、2文字単位でのローテーション・・・・
記述した全部は以下

Public Sub test4444()
  Dim nTotal As Long
  Dim sFileName As String
  Dim vAry As Variant, vSub As Variant
  Dim vChk As Variant, iChkHdn() As Long, sChk() As String
  Dim iAryEmt As Long, vPos As Variant, iNxtPos As Long
  Dim dic As Object, vDic As Variant
  Dim v As Variant, vv As Variant
  Dim sS As String
  Dim i As Long, j As Long
  Dim iEcnt As Long, iFaceNum As Long
  Dim st As Single
  Const CBLK As Long = 3

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

'    vAry = Array("A3:A6", "A7:A10", "A11:A14", "A15:A18")

'    vAry = Array("A3:A6", "A7:A10", "A11:A14", "A15:A18", _
'          "A19:A22", "A23:A26")

'    vAry = Array("A3:A6", "A7:A10", "A11:A14", "A15:A18", _
'          "A19:A22", "A23:A26", "A27:A30", "A31:A34")

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

'    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", _
'          "A51:A54", "A55:A58", "A59:A62", "A63:A66", _
'          "A67:A70", "A71:A74", "A75:A78", "A79:A82")

    ReDim vSub(UBound(vAry))
    j = 1
    For i = 0 To UBound(vSub)
      vSub(i) = .Range(vAry(i))
      j = j * UBound(vSub(i))
      If (j > nTotal) Then
        iFaceNum = i
        j = 0
      End If
    Next
    If (i <= 6) Then iFaceNum = 3
    i = UBound(vSub) + 1
    j = 0
    If ((i Mod CBLK) = 0) Then j = 1
    ReDim vChk(i \ CBLK - j)
    ReDim sChk(i \ CBLK - j)
    ReDim iChkHdn(i \ CBLK - j)
    iAryEmt = CBLK
    iNxtPos = 0

    For j = 0 To UBound(vChk)
      If ((i - iNxtPos) < iAryEmt) Then iAryEmt = i - iNxtPos
      ReDim vPos(iAryEmt - 1)

      v = Empty
      Call mkPtn(vSub, vPos, iAryEmt, iNxtPos, v)
      vChk(j) = v
      iNxtPos = iNxtPos + iAryEmt
    Next
  End With

  j = 1
  For i = 0 To UBound(vChk)
    j = j * (UBound(vChk(i)) + 1)
    If (j > nTotal) Then Exit For
  Next
  If (j <= nTotal) Then
    ReDim vPos(UBound(vSub))
    vDic = Empty
    Call mkPtn(vSub, vPos, UBound(vSub) + 1, 0, vDic)

  Else
    Randomize

    Set dic = CreateObject("Scripting.Dictionary")

    For i = 0 To UBound(iChkHdn)
      iChkHdn(i) = Int(UBound(vChk(i)) * Rnd())
    Next
    Do While (1)
      iEcnt = 0
      While ((dic.Count < nTotal) And (iEcnt < 5000))
        For i = 0 To UBound(sChk)
          sChk(i) = fncPtnGet(iChkHdn(i), vChk(i))
        Next
        sS = Join(sChk, ",")
        If (dic.Count = 0) Then
          dic(sS) = Null
          v = dic.Keys
        Else
          For i = 1 To 2
            j = fncPtnChk(iFaceNum, CBLK, v, sS)
            If (j < 0) Then
              dic(sS) = Null
              v = dic.Keys
              Exit For
            End If
            If (i = 1) Then
              sChk(j) = fncPtnGet(iChkHdn(j), vChk(j))
              sS = Join(sChk, ",")
            End If
          Next
        End If
        iEcnt = iEcnt + 1
      Wend
      Debug.Print iFaceNum, dic.Count, iEcnt, Timer() - st
      If (dic.Count >= nTotal) Then Exit Do
      iFaceNum = iFaceNum + 1
      If (iFaceNum > (UBound(vSub) + 1)) Then Exit Do
    Loop
    vDic = dic.Keys
    Set dic = Nothing
  End If

  With Worksheets("Sheet3")
    .Cells.ClearContents
    With .Range("A1")
      For i = 0 To UBound(vDic)
        sS = ""
        v = Split(vDic(i), ",")
        For j = 0 To UBound(vSub)
          sS = sS & vSub(j)(v(j), 1)
        Next
        .Offset(i, 0) = sS
      Next
      With .Offset(0, 1).Resize(i, UBound(vSub))
        .FormulaR1C1 = "=RIGHT(RC[-1]," & UBound(vSub) * 2 & ")&LEFT(RC[-1],2)"
        .Value = .Value
      End With
    End With
    For j = Asc("A") To Asc("A") + UBound(vSub) + 1
      .Range(Chr(j) & "1:" & Chr(j) & i).Sort Key1:=.Range(Chr(j) & "1")
    Next
    .Columns.AutoFit
  End With

  Debug.Print ">> 時間: " & Timer() - st
End Sub

Private Sub mkPtn(vSub As Variant, vPos As Variant _
      , iAryEmt As Long, iNxtPos As Long, vRet As Variant)
  Dim i As Long, j As Long
  Dim v As Variant

  If (iAryEmt <= 0) Then
    If (IsEmpty(vRet)) Then
      ReDim vRet(0)
    Else
      ReDim Preserve vRet(UBound(vRet) + 1)
    End If
    vRet(UBound(vRet)) = Join(vPos, ",")
  Else
    For i = LBound(vSub(iNxtPos)) To UBound(vSub(iNxtPos))
      vPos(UBound(vPos) - iAryEmt + 1) = i
      Call mkPtn(vSub, vPos, iAryEmt - 1, iNxtPos + 1, vRet)
    Next
  End If
End Sub

Private Function fncPtnGet(iHdn As Long, vAry As Variant) As String
  Dim i As Long, r As Long
  Dim v As Variant

  i = UBound(vAry) - iHdn
  r = Int((i + 1) * Rnd())
  v = vAry(r)
  vAry(r) = vAry(i)
  vAry(i) = v
  iHdn = iHdn + 1
  If (iHdn > UBound(vAry)) Then iHdn = 0
  fncPtnGet = v
End Function

Private Function fncPtnChk(iFaceNum As Long, iAryEmt As Long _
          , vAry As Variant, sSrc As String) As Long
  Dim v As Variant
  Dim v1 As Variant, v2 As Variant
  Dim i As Long, iCnt As Long

  fncPtnChk = -1
  v2 = Split(sSrc, ",")
  For Each v In vAry
    v1 = Split(v, ",")
    iCnt = 0
    For i = 0 To UBound(v2)
      If (v1(i) = v2(i)) Then
        iCnt = iCnt + 1
        If (iCnt >= iFaceNum) Then
          fncPtnChk = i \ iAryEmt
          Exit Function
        End If
      End If
    Next
  Next
End Function

 
※ 一言メモ Join をうまく使おう
例えば、Long 型の配列があって、それを ","(カンマ)で区切った文字列を作りたい・・・
配列の型が Long なので Join は使えないですね・・・ 実行時エラー 5 に
素直にやるとすれば、以下の様な感じ?

For i ループFor Each ループ
    Dim iPos(3) As Long
    Dim sS As String
    Dim i As Long

    sS = ""
    For i = 0 To 3
        sS = sS & "," & iPos(i)
    Next
    sS = Mid(sS, 2)
    Dim iPos(3) As Long
    Dim sS As String
    Dim v As Variant

    sS = ""
    For Each v In iPos
        sS = sS & "," & v
    Next
    sS = Mid(sS, 2)
    Dim iPos(3) As Long
    Dim sS As String, sH As String
    Dim i As Long

    sS = ""
    sH = ""
    For i = 0 To 3
        sS = sS & sH & iPos(i)
        sH = ","
    Next
    Dim iPos(3) As Long
    Dim sS As String, sH As String
    Dim v As Variant

    sS = ""
    sH = ""
    For Each v In iPos
        sS = sS & sH & v
        sH = ","
    Next

でも、配列を Variant で持てば、Join はエラーなく使えますね・・・格納する値が Long でも・・・
ただ、実行速度がどうなのかは・・・わかりません


上記「test4444」をやってみて・・・・ どこか速くする所はないのかな・・・していると、
重複が、チェックする面数以上だったら、見つかったブロック以降を再取得&再チェックしてましたが、
ここで重複しないものになる頻度が極小という事がわかりました。

そこで、重複チェックに引っ掛かったら、また最初から求め直す事に・・・
それが「test44444」になり、変更した部分は以下になります。

    Do While (1)
      iEcnt = 0
      While ((dic.Count < nTotal) And (iEcnt < 5000))
        For i = 0 To UBound(sChk)
          sChk(i) = fncPtnGet(iChkHdn(i), vChk(i))
        Next
        sS = Join(sChk, ",")
        If (dic.Count = 0) Then
          dic(sS) = Null
          v = dic.Keys
        ElseIf (fncPtnChk(iFaceNum, CBLK, v, sS) < 0) Then
          dic(sS) = Null
          v = dic.Keys

        End If
        iEcnt = iEcnt + 1
      Wend
      Debug.Print iFaceNum, dic.Count, iEcnt, Timer() - st
      If (dic.Count >= nTotal) Then Exit Do
      iFaceNum = iFaceNum + 1
      If (iFaceNum > (UBound(vSub) + 1)) Then Exit Do
    Loop


Excel でやってみたのは以上になります。
ここまでの記述は、今回のサンプル zip に「w_kEnt194.xls」として入っています

以降は Access でのお話になります
Access で実行確認する際、上記の「w_kEnt194.xls」が同じ場所にあるものとして参照しています。
共通の Access での処理は
・「w_kEnt194.xls」を非表示で開いて「Sheet1」の内容を参照
・Access での処理 ★★ ここが色々と違ってきます
・結果を「Sheet2」に書き出し
・Excel を表示

連続して実行していくと、
Excel が複数立ち上がることにもなるので、確認したら Excel を閉じる・・・が、良いかも
また、Access の処理過程で Debug.Print しているので、イミディエイトウィンドウを表示しておいた方が・・・・
なお、12面の時についてのみ考えていきます(面数は定義により変更できるようになってますが・・・)


乱数で必要数の数倍のレコードを生成しておいて、そこから重複しているものを排除していく

これ、前回記事にサラッと紹介したものになります。
それをちょっと見なおしたもの(考え方は同じです)

テーブル「T25」を事前に作成しておきます。
フィールドは、「an」オートナンバ、「F1」~「F12」長整数・インデックス重複あり

処理概要)

・Excel ファイルから必要な情報を入手します
・必要数分 * 6 のレコードを作成します(必要数=400 なので 2400 レコード分)
 レコードを作成する時には、「F1」~「F12」には各面の位置情報を乱数で
  CurrentProject.Connection.Execute "DELETE * FROM T25;"
  rs.Open "T25", CurrentProject.Connection, adOpenStatic, adLockOptimistic
  For i = 1 To nTotal * 6
    rs.AddNew
    For j = 0 To UBound(vSub)
      rs("F" & j + 1) = Int(UBound(vSub(j)) * Rnd()) + 1
    Next
    rs.Update
  Next
  rs.Close

・1 ~ 12 の値を持つ配列から何個か乱数にて抽出します(何個も乱数で)
 その抽出したもので SQL を作成し、実行します
  Const CSQL As String = "DELETE * FROM T25 AS Q1 " _
            & "WHERE EXISTS (SELECT 1 FROM T25 WHERE (an > Q1.an)"
  Const CSQLSUB As String = "(F{%1}=Q1.F{%1})"
  Const CANDOR As String = " AND "
・・・・
    For j = 0 To UBound(iPos)
      iPos(j) = j + 1
    Next
    For j = 1 To Int((UBound(iPos) \ 3) * Rnd()) + UBound(iPos) \ 2
      k = Int((UBound(iPos) - iLast + 1) * Rnd())
      sSql = sSql & CANDOR & Replace(CSQLSUB, "{%1}", iPos(k))
      iPos(k) = iPos(UBound(iPos) - iLast)
      iLast = iLast + 1
    Next
    Debug.Print sSql
    sSql = CSQL & sSql & ");"
    CurrentProject.Connection.Execute sSql

説明上数を少なくしたものにしますが、4, 7, 9 の数字が乱数で求まったとすると出来上がる SQL は
DELETE * FROM T25 AS Q1
WHERE EXISTS (SELECT 1 FROM T25 WHERE (an > Q1.an)
AND (F4=Q1.F4) AND (F7=Q1.F7) AND (F9=Q1.F9));
になります
「F4」「F7」「F9」の中の値はわからないけど、同じものがあったら削除・・・
ただ、全部を削除するんじゃなくて1つは残しましょうか・・・・ってんで、an > Q1.an を条件に入れてました。
iLast っていう変数は、1 ~ 12 を抽出する時に重複しない様に・・・・っていう管理上のものです

・必要数分 * 2 内のレコード数になったら、どんな削除結果になっているかわからないけど
 「an」昇順で必要数分を TOP 指定で抽出
・抽出後は、GetRows でレコード内容を変数に展開(こっちの方が速そう??? 裏付けなし)
  rs.Source = "SELECT TOP " & nTotal & " * FROM T25 ORDER BY an;"
  rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  v = rs.GetRows
  rs.Close

これをやった後には注意があって、得られるのは二次元配列になりますが、並びは Excel と逆
Access では、変数(列, レコード)・・・・ で、0 スタート
Excel では、変数(行, 列)・・・・ で、1 スタート( 変数 = Range("A1:C5") とか・・・)
ReDim Preserve とか考えると、Access の方が考えやすいのかなぁ~~

で、書き直してみたのが以下(標準モジュール「Module1」)
Public Sub test()
  Dim rs As New ADODB.Recordset
  Dim sSql As String
  Dim oApp As Object
  Dim nTotal As Long
  Dim sFileName As String
  Dim vAry As Variant, vSub As Variant, iPos() As Long
  Dim v As Variant, vv As Variant
  Dim sS As String
  Dim i As Long, j As Long, k As Long
  Dim iEcnt As Long, iLast As Long
  Dim st As Single

  Const CFILE As String = "\w_kEnt194.xls"
  Const CSQL As String = "DELETE * FROM T25 AS Q1 " _
            & "WHERE EXISTS (SELECT 1 FROM T25 WHERE (an > Q1.an)"
  Const CSQLSUB As String = "(F{%1}=Q1.F{%1})"
  Const CANDOR As String = " AND "

  st = Timer()
  Set oApp = CreateObject("Excel.Application")
  oApp.Workbooks.Open CurrentProject.Path & CFILE

  With oApp.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:A50")

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

  Debug.Print Timer() - st
  Randomize

  CurrentProject.Connection.Execute "DELETE * FROM T25;"
  rs.Open "T25", CurrentProject.Connection, adOpenStatic, adLockOptimistic
  For i = 1 To nTotal * 6
    rs.AddNew
    For j = 0 To UBound(vSub)
      rs("F" & j + 1) = Int(UBound(vSub(j)) * Rnd()) + 1
    Next
    rs.Update
  Next
  rs.Close

  iEcnt = 0
  Do While (iEcnt < 5000)
    sSql = ""
    iLast = 0
    For j = 0 To UBound(iPos)
      iPos(j) = j + 1
    Next
    For j = 1 To Int((UBound(iPos) \ 3) * Rnd()) + UBound(iPos) \ 2
      k = Int((UBound(iPos) - iLast + 1) * Rnd())
      sSql = sSql & CANDOR & Replace(CSQLSUB, "{%1}", iPos(k))
      iPos(k) = iPos(UBound(iPos) - iLast)
      iLast = iLast + 1
    Next
    Debug.Print sSql
    sSql = CSQL & sSql & ");"
    CurrentProject.Connection.Execute sSql
    j = DCount("*", "T25")
    Debug.Print ">> " & j, Timer() - st
    If (j < nTotal * 2) Then Exit Do
    iEcnt = iEcnt + 1
  Loop

  rs.Source = "SELECT TOP " & nTotal & " * FROM T25 ORDER BY an;"
  rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  v = rs.GetRows
  rs.Close

  With oApp.Worksheets("Sheet2")
    .Cells.ClearContents
    With .Range("B1")
      For i = 0 To UBound(v, 2)
        sS = ""
        For j = 0 To UBound(vSub)
          sS = sS & vSub(j)(v(j + 1, i), 1)
        Next
        .Offset(i, 0) = sS
      Next
    End With
    .Range("B1:B" & UBound(v, 2) + 1).Sort Key1:=.Range("B1")
    .Range("A1").Resize(UBound(v, 2) + 1) = sFileName
  End With

  oApp.Visible = True
  Set oApp = Nothing
  Debug.Print "時間", Timer() - st
End Sub

 
※ 前回の時も書いてましたが、削除によって必要数分を下回った場合の記述はありません。

イミディエイトウィンドウを開いておいて、「test」を実行・・・・で
Excel ファイルが表示されたら、処理終わり・・・・ Excel ファイルは保存しないで閉じたりしてください
私のPCで、7秒前後ですね・・・
出来上がったパターンを見渡して・・・7つ・8つの重複は結構ありますね
でも、実行するたびに変わってくるので、好きなパターンを選ぶのも良いのかも

7つが一緒・・・で削除すると20レコード位が対象になる雰囲気
7つの全パターンで削除してみるっていうのもありなのかなぁ~~
それによっては、元のレコード数をもう少し増やしてみるとか・・・・???


※※ 今まで(Excel)での考え方は作り込む時に重複があるか・・・・していました
上記では重複を削除していくものになってました。
これ・・・単純に確認するには・・・・ということで、
・全パターン 16777216 レコードを作る
・そこから、どの様に削除していったら・・・・
全パターンを作成するのは、標準モジュール「Module_etc」に記述しコメントにしてあります。
これを実行すると、1G 近いファイルサイズになります。
私はそれ以降、何かをしようとは思わなかったので、コメントで残してます。
お好きな方はどうぞ・・・ っていうことで


以下、考え方は元に戻って、作り込む時に重複をチェックして・・・・


テーブルの持ち方を変えてみる

テーブル「T26A」「T26B」同じ構成のものを事前に作っておきます
フィールドは、「an」オートナンバ、「組」「面」「値」長整数
「組」は、パターンごとに共通の値
「面」は、0 ~ 11 の面番号
「値」は、元々の色を管理している配列の位置情報(各面、色4つなので 1 ~ 4 )

テーブル「T26A」「T26B」の用途は
「T26A」:重複をチェックしてチェックを通り抜けたもの
「T26B」:「T26A」に登録する前に重複をチェックするもの

重複のチェックは、以下の SQL で行います
  Const CSQLCHK As String = "" _
          & "SELECT DISTINCT Q2.組 FROM " _
          & "(SELECT 組, 面, 値 FROM T26A " _
          & "UNION ALL " _
          & "SELECT 組, 面, 値 FROM T26B) AS Q1 " _
          & "INNER JOIN T26B AS Q2 " _
          & "ON Q1.面=Q2.面 AND Q1.値=Q2.値 " _
          & "WHERE Q1.組 <> Q2.組 " _
          & "GROUP BY Q1.組, Q2.組 " _
          & "HAVING Count(*) >= {%1}; "
{%1}部分は、即値に置換えて実行します。
つまり、5面で重複なら HAVING Count(*) >= 5 として実行します
これは、「組」が異なり「面」「値」が同じものを、OK済の「T26A」と追加したい「T26B」で確認し、
HAVING で引っ掛かった「T26B」側の「組」を重複なしで入手します。
UNION を使って「T26A」「T26B」を作っているのは、「T26B」内にも重複するものがあるかもしれない・・・・
(「T26B」に1度に入れるパターン数は5組としていました)
もし対象の「組」があったら、","(カンマ)区切りの文字列にします。
この文字列が空文字列なら「T26B」から「T26A」に全て INSERT します。
重複するものがあって、文字列が出来上がっていたら、「T26B」に入れた「組」全部なのか・・・確認します
全部じゃなかっら、重複で引っ掛かった「組」を「T26B」から削除後、残ったものを「T26A」へ・・・

※ 削除して残ったものを INSERT ・・・・・以下の考え方でも良いですねって、そっちの方が良いかも
削除操作はしないで、INSERT の時に 「組」に対して Not IN 指定・・・

  Const CSQLDEL As String = "" _
          & "DELETE * FROM T26B WHERE 組 IN ({%1}0);"
  Const CSQLINS As String = "" _
          & "INSERT INTO T26A(組, 面, 値) " _
          & "SELECT 組, 面, 値 FROM T26B;"
・・・・
      sS = ""
      rs.Open sSql, CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
      If (Not rs.EOF) Then
        sS = rs.GetString(adClipString, , "", ",")
      End If
      rs.Close
      If (Len(sS) = 0) Then
        CurrentProject.Connection.Execute CSQLINS
      ElseIf ((Len(sS) - Len(Replace(sS, ",", ""))) <> CLOOPNUM) Then
        CurrentProject.Connection.Execute Replace(CSQLDEL, "{%1}", sS)
        CurrentProject.Connection.Execute CSQLINS
      End If

sS = rs.GetString(adClipString, , "", ",") 時には、文字列最後に "," が付くので
・その最後の "," を削除するか
・「組」に存在しない値 0 を付加するか( ({%1}0) 部分の {%1} を単純置換え)
今回は後者の方法で・・・

以下の処理では、
・テーブル「T26B」へは、1度に5組を生成
・重複面数のチェックは、初期:5 として、順次増やしていく
 ( 5 でチェックするという事は、重複は4つまで認めるという事に・・・)
・1つの重複面数で試行するのは 1000 回

標準モジュール「Module2」
Public Sub test2()
  Dim rs As New ADODB.Recordset
  Dim sSql As String
  Dim oApp As Object
  Dim nTotal As Long
  Dim sFileName As String
  Dim vAry As Variant, vSub As Variant
  Dim v As Variant, vv As Variant
  Dim sS As String
  Dim i As Long, j As Long, k As Long
  Dim iEcnt As Long, iFaceNum As Long, iCnt As Long
  Dim st As Single

  Const CLOOPNUM As Long = 5
  Const CFILE As String = "\w_kEnt194.xls"
  Const CSQLCHK As String = "" _
          & "SELECT DISTINCT Q2.組 FROM " _
          & "(SELECT 組, 面, 値 FROM T26A " _
          & "UNION ALL " _
          & "SELECT 組, 面, 値 FROM T26B) AS Q1 " _
          & "INNER JOIN T26B AS Q2 " _
          & "ON Q1.面=Q2.面 AND Q1.値=Q2.値 " _
          & "WHERE Q1.組 <> Q2.組 " _
          & "GROUP BY Q1.組, Q2.組 " _
          & "HAVING Count(*) >= {%1}; "
  Const CSQLDEL As String = "" _
          & "DELETE * FROM T26B WHERE 組 IN ({%1}0);"
  Const CSQLINS As String = "" _
          & "INSERT INTO T26A(組, 面, 値) " _
          & "SELECT 組, 面, 値 FROM T26B;"
  Const CSQLGET As String = "" _
          & "TRANSFORM First(値) " _
          & "SELECT 組 " _
          & "FROM T26A " _
          & "GROUP BY 組 " _
          & "PIVOT 面; "
  st = Timer()

  Set oApp = CreateObject("Excel.Application")
  oApp.Workbooks.Open CurrentProject.Path & CFILE

  With oApp.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:A50")

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

  Debug.Print Timer() - st
  Randomize

  CurrentProject.Connection.Execute "DELETE * FROM T26A;"
  iCnt = 1
  iFaceNum = 5
  Do While (1)
    iEcnt = 0
    sSql = Replace(CSQLCHK, "{%1}", iFaceNum)
    While ((DCount("*", "T26A") < nTotal * (UBound(vSub) + 1)) And (iEcnt < 1000))
      CurrentProject.Connection.Execute "DELETE * FROM T26B;"
      rs.Open "T26B", CurrentProject.Connection, adOpenForwardOnly, adLockOptimistic
      For i = 1 To CLOOPNUM
        For j = 0 To UBound(vSub)
          rs.AddNew
          rs("組") = iCnt
          rs("面") = j
          rs("値") = Int(UBound(vSub(j)) * Rnd()) + 1
          rs.Update
        Next
        iCnt = iCnt + 1
      Next
      rs.Close
      sS = ""
      rs.Open sSql, CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
      If (Not rs.EOF) Then
        sS = rs.GetString(adClipString, , "", ",")
      End If
      rs.Close
      If (Len(sS) = 0) Then
        CurrentProject.Connection.Execute CSQLINS
      ElseIf ((Len(sS) - Len(Replace(sS, ",", ""))) <> CLOOPNUM) Then
        CurrentProject.Connection.Execute Replace(CSQLDEL, "{%1}", sS)
        CurrentProject.Connection.Execute CSQLINS
      End If
      iEcnt = iEcnt + 1
    Wend
    Debug.Print iFaceNum, DCount("*", "T26A") / (UBound(vSub) + 1), iEcnt, Timer() - st
    If (DCount("*", "T26A") >= nTotal * (UBound(vSub) + 1)) Then Exit Do
    iFaceNum = iFaceNum + 1
    If (iFaceNum > (UBound(vSub) + 1)) Then Exit Do
  Loop

  rs.Open CSQLGET, CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  v = rs.GetRows
  rs.Close

  With oApp.Worksheets("Sheet2")
    .Cells.ClearContents
    With .Range("B1")
      nTotal = nTotal - 1
      If (UBound(v, 2) < nTotal) Then nTotal = UBound(v, 2)
      For i = 0 To nTotal
        sS = ""
        For j = 0 To UBound(vSub)
          sS = sS & vSub(j)(v(j + 1, i), 1)
        Next
        .Offset(i, 0) = sS
      Next
    End With
    .Range("B1:B" & nTotal + 1).Sort Key1:=.Range("B1")
    .Range("A1").Resize(nTotal + 1) = sFileName
  End With

  oApp.Visible = True
  Set oApp = Nothing
  Debug.Print "時間", Timer() - st
End Sub

 
実行すると、170秒前後で処理が終わります。

※ 一言メモ 結果は配列で扱いやすいようにクロス集計で
テーブル「T26A」は、フィールド「an」「組」「面」「値」からなっていますが、
配列で値を入手しやすいようにクロス集計で、「組」・・・1レコード、列(フィールド)側を「面」で・・・
  Const CSQLGET As String = "" _
          & "TRANSFORM First(値) " _
          & "SELECT 組 " _
          & "FROM T26A " _
          & "GROUP BY 組 " _
          & "PIVOT 面; "
PIVOT 面 ・・・・ としているので、作成される列(フィールド)は数値の昇順に並んでくれます
列の並びを考えないといけないのは、文字列として作成される場合です。
例えば、
PIVOT Month(日付) & "月"
とかしてしまうと、1月、10月、・・・2月、3月 の様に並んでしまうので・・・


これで確認していると、「T26B」に対して1度に作成する「組」数が少なくなればなるほど速くなるみたい・・・
じゃぁ、「T26B」に登録して重複確認するのは1組限定にしましょう・・・・というのが、次になります。


重複チェックは1パターンごとに

テーブル「T26A」「T26B」の使い方は同じです。
チェックしたいパターンを「T26B」に1組だけ入れて試行を繰り返します。
1組だけ入れる・・・・ SQL の組方を変更しています。

重複の確認
  Const CSQLCHK As String = "" _
          & "SELECT Q1.組 FROM " _
          & "T26A AS Q1 INNER JOIN T26B AS Q2 " _
          & "ON Q1.面=Q2.面 AND Q1.値=Q2.値 " _
          & "GROUP BY Q1.組 " _
          & "HAVING Count(*) >= {%1}; "

結構シンプルになりましたね
重複したかどうかは、True / False だけで良いのですが、一応「組」を得ておこうかな・・・
でも、チェックするのはレコードがあるか、ないか・・・だけですけど
一応、記述してやってみたのが「test31」・・・・ ADO での記述
以前、何かの時・・・・DAO でやってみたら ADO より速かった・・・・という記憶があったので
「test32」として、DAO 記述で・・・・
やっている処理は同じです。
やってみて良かったなぁ・・・っていう箇所が1つあって、クロス集計の結果を GetRows で入手するのですが
ADO では、引数していなくとも全件得る事が出来ましたが、DAO では、
  v = rs.GetRows(nTotal)
と、欲しい件数を指定しないと、1件だけ・・・
やってみていませんが、MoveLast して、MoveFirst した後では引数はいらないのかも???

標準モジュール「Module3」  「test31」ADO 記述 / 「test32」DAO 記述
Public Sub test31()
  Dim rs As New ADODB.Recordset
  Dim sSql As String
  Dim oApp As Object
  Dim nTotal As Long
  Dim sFileName As String
  Dim vAry As Variant, vSub As Variant
  Dim v As Variant, vv As Variant
  Dim sS As String
  Dim i As Long, j As Long, k As Long
  Dim iEcnt As Long, iFaceNum As Long, iCnt As Long
  Dim st As Single

  Const CFILE As String = "\w_kEnt194.xls"
  Const CSQLCHK As String = "" _
          & "SELECT Q1.組 FROM " _
          & "T26A AS Q1 INNER JOIN T26B AS Q2 " _
          & "ON Q1.面=Q2.面 AND Q1.値=Q2.値 " _
          & "GROUP BY Q1.組 " _
          & "HAVING Count(*) >= {%1}; "
  Const CSQLINS As String = "" _
          & "INSERT INTO T26A(組, 面, 値) " _
          & "SELECT 組, 面, 値 FROM T26B;"
  Const CSQLGET As String = "" _
          & "TRANSFORM First(値) " _
          & "SELECT 組 " _
          & "FROM T26A " _
          & "GROUP BY 組 " _
          & "PIVOT 面; "
  st = Timer()

  Set oApp = CreateObject("Excel.Application")
  oApp.Workbooks.Open CurrentProject.Path & CFILE

  With oApp.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:A50")

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

  Debug.Print Timer() - st
  Randomize

  CurrentProject.Connection.Execute "DELETE * FROM T26A;"
  iCnt = 1
  iFaceNum = 5
  Do While (1)
    iEcnt = 0
    sSql = Replace(CSQLCHK, "{%1}", iFaceNum)
    While ((DCount("*", "T26A") < nTotal * (UBound(vSub) + 1)) And (iEcnt < 1000))
      CurrentProject.Connection.Execute "DELETE * FROM T26B;"
      rs.Open "T26B", CurrentProject.Connection, adOpenForwardOnly, adLockOptimistic
      For j = 0 To UBound(vSub)
        rs.AddNew
        rs("組") = iCnt
        rs("面") = j
        rs("値") = Int(UBound(vSub(j)) * Rnd()) + 1
        rs.Update
      Next
      iCnt = iCnt + 1
      rs.Close
      sS = ""
      rs.Open sSql, CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
      If (Not rs.EOF) Then sS = "FOUND"
      rs.Close
      If (Len(sS) = 0) Then CurrentProject.Connection.Execute CSQLINS
      iEcnt = iEcnt + 1
    Wend
    Debug.Print iFaceNum, DCount("*", "T26A") / (UBound(vSub) + 1), iEcnt, Timer() - st
    If (DCount("*", "T26A") >= nTotal * (UBound(vSub) + 1)) Then Exit Do
    iFaceNum = iFaceNum + 1
    If (iFaceNum > (UBound(vSub) + 1)) Then Exit Do
  Loop

  rs.Open CSQLGET, CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  v = rs.GetRows
  rs.Close

  With oApp.Worksheets("Sheet2")
    .Cells.ClearContents
    With .Range("B1")
      nTotal = nTotal - 1
      If (UBound(v, 2) < nTotal) Then nTotal = UBound(v, 2)
      For i = 0 To nTotal
        sS = ""
        For j = 0 To UBound(vSub)
          sS = sS & vSub(j)(v(j + 1, i), 1)
        Next
        .Offset(i, 0) = sS
      Next
    End With
    .Range("B1:B" & nTotal + 1).Sort Key1:=.Range("B1")
    .Range("A1").Resize(nTotal + 1) = sFileName
  End With

  oApp.Visible = True
  Set oApp = Nothing
  Debug.Print "時間", Timer() - st
End Sub


Public Sub test32()
  Dim rs As DAO.Recordset
  Dim sSql As String
  Dim oApp As Object
  Dim nTotal As Long
  Dim sFileName As String
  Dim vAry As Variant, vSub As Variant
  Dim v As Variant, vv As Variant
  Dim sS As String
  Dim i As Long, j As Long, k As Long
  Dim iEcnt As Long, iFaceNum As Long, iCnt As Long
  Dim st As Single

  Const CFILE As String = "\w_kEnt194.xls"
  Const CSQLCHK As String = "" _
          & "SELECT Q1.組 FROM " _
          & "T26A AS Q1 INNER JOIN T26B AS Q2 " _
          & "ON Q1.面=Q2.面 AND Q1.値=Q2.値 " _
          & "GROUP BY Q1.組 " _
          & "HAVING Count(*) >= {%1}; "
  Const CSQLINS As String = "" _
          & "INSERT INTO T26A(組, 面, 値) " _
          & "SELECT 組, 面, 値 FROM T26B;"
  Const CSQLGET As String = "" _
          & "TRANSFORM First(値) " _
          & "SELECT 組 " _
          & "FROM T26A " _
          & "GROUP BY 組 " _
          & "PIVOT 面; "
  st = Timer()

  Set oApp = CreateObject("Excel.Application")
  oApp.Workbooks.Open CurrentProject.Path & CFILE

  With oApp.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:A50")

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

  Debug.Print Timer() - st
  Randomize

  CurrentDb.Execute "DELETE * FROM T26A;"
  iCnt = 1
  iFaceNum = 5
  Do While (1)
    iEcnt = 0
    sSql = Replace(CSQLCHK, "{%1}", iFaceNum)
    While ((DCount("*", "T26A") < nTotal * (UBound(vSub) + 1)) And (iEcnt < 1000))
      CurrentDb.Execute "DELETE * FROM T26B;"
      Set rs = CurrentDb.OpenRecordset("T26B")
      For j = 0 To UBound(vSub)
        rs.AddNew
        rs("組") = iCnt
        rs("面") = j
        rs("値") = Int(UBound(vSub(j)) * Rnd()) + 1
        rs.Update
      Next
      iCnt = iCnt + 1
      rs.Close
      sS = ""
      Set rs = CurrentDb.OpenRecordset(sSql)
      If (Not rs.EOF) Then sS = "FOUND"
      rs.Close
      If (Len(sS) = 0) Then CurrentDb.Execute CSQLINS
      iEcnt = iEcnt + 1
    Wend
    Debug.Print iFaceNum, DCount("*", "T26A") / (UBound(vSub) + 1), iEcnt, Timer() - st
    If (DCount("*", "T26A") >= nTotal * (UBound(vSub) + 1)) Then Exit Do
    iFaceNum = iFaceNum + 1
    If (iFaceNum > (UBound(vSub) + 1)) Then Exit Do
  Loop

  Set rs = CurrentDb.OpenRecordset(CSQLGET)
  v = rs.GetRows(nTotal)
  rs.Close
  Set rs = Nothing

  With oApp.Worksheets("Sheet2")
    .Cells.ClearContents
    With .Range("B1")
      nTotal = nTotal - 1
      If (UBound(v, 2) < nTotal) Then nTotal = UBound(v, 2)
      For i = 0 To nTotal
        sS = ""
        For j = 0 To UBound(vSub)
          sS = sS & vSub(j)(v(j + 1, i), 1)
        Next
        .Offset(i, 0) = sS
      Next
    End With
    .Range("B1:B" & nTotal + 1).Sort Key1:=.Range("B1")
    .Range("A1").Resize(nTotal + 1) = sFileName
  End With

  oApp.Visible = True
  Set oApp = Nothing
  Debug.Print "時間", Timer() - st
End Sub

 
実行速度の雰囲気は、「test31」:70秒前後  「test32」:35秒前後
結構違うもんですね・・・


次に試してみたのは、
・レコードセットの Open / Close の回数を減らしましょう・・・
・重複があるかどうかで得られるレコード数は1件にしましょう・・・

標準モジュール「Module4」  「test41」ADO 記述 / 「test42」DAO 記述
Public Sub test41()
  Dim rs As New ADODB.Recordset
  Dim rsB As New ADODB.Recordset
  Dim rsC As New ADODB.Recordset

  Dim sSql As String
  Dim oApp As Object
  Dim nTotal As Long
  Dim sFileName As String
  Dim vAry As Variant, vSub As Variant
  Dim v As Variant, vv As Variant
  Dim sS As String
  Dim i As Long, j As Long, k As Long
  Dim iEcnt As Long, iFaceNum As Long, iCnt As Long
  Dim st As Single

  Const CFILE As String = "\w_kEnt194.xls"
  Const CSQLCHK As String = "" _
          & "SELECT First(Q1.組) FROM " _
          & "T26A AS Q1 INNER JOIN T26B AS Q2 " _
          & "ON Q1.面=Q2.面 AND Q1.値=Q2.値 " _
          & "GROUP BY Q1.組 " _
          & "HAVING Count(*) >= {%1}; "
  Const CSQLINS As String = "" _
          & "INSERT INTO T26A(組, 面, 値) " _
          & "SELECT 組, 面, 値 FROM T26B;"
  Const CSQLGET As String = "" _
          & "TRANSFORM First(値) " _
          & "SELECT 組 " _
          & "FROM T26A " _
          & "GROUP BY 組 " _
          & "PIVOT 面; "
  st = Timer()

  Set oApp = CreateObject("Excel.Application")
  oApp.Workbooks.Open CurrentProject.Path & CFILE

  With oApp.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:A50")

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

  Debug.Print Timer() - st
  Randomize

  CurrentProject.Connection.Execute "DELETE * FROM T26A;"
  CurrentProject.Connection.Execute "DELETE * FROM T26B;"
  iCnt = 1
  iFaceNum = 5
  rsB.Open "T26B", CurrentProject.Connection, adOpenForwardOnly, adLockOptimistic
  Do While (1)
    iEcnt = 0
    rsC.Source = Replace(CSQLCHK, "{%1}", iFaceNum)
    rsC.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly

    While ((DCount("*", "T26A") < nTotal * (UBound(vSub) + 1)) And (iEcnt < 1000))
      CurrentProject.Connection.Execute "DELETE * FROM T26B;"
      For j = 0 To UBound(vSub)
        rsB.AddNew
        rsB("組") = iCnt
        rsB("面") = j
        rsB("値") = Int(UBound(vSub(j)) * Rnd()) + 1
        rsB.Update
      Next
      iCnt = iCnt + 1
      
      sS = ""
      rsC.Requery
      If (Not rsC.EOF) Then sS = "FOUND"
      If (Len(sS) = 0) Then CurrentProject.Connection.Execute CSQLINS
      iEcnt = iEcnt + 1
    Wend
    rsC.Close
    Debug.Print iFaceNum, DCount("*", "T26A") / (UBound(vSub) + 1), iEcnt, Timer() - st
    If (DCount("*", "T26A") >= nTotal * (UBound(vSub) + 1)) Then Exit Do
    iFaceNum = iFaceNum + 1
    If (iFaceNum > (UBound(vSub) + 1)) Then Exit Do
  Loop
  rsB.Close

  rs.Open CSQLGET, CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  v = rs.GetRows
  rs.Close

  With oApp.Worksheets("Sheet2")
    .Cells.ClearContents
    With .Range("B1")
      nTotal = nTotal - 1
      If (UBound(v, 2) < nTotal) Then nTotal = UBound(v, 2)
      For i = 0 To nTotal
        sS = ""
        For j = 0 To UBound(vSub)
          sS = sS & vSub(j)(v(j + 1, i), 1)
        Next
        .Offset(i, 0) = sS
      Next
    End With
    .Range("B1:B" & nTotal + 1).Sort Key1:=.Range("B1")
    .Range("A1").Resize(nTotal + 1) = sFileName
  End With

  oApp.Visible = True
  Set oApp = Nothing
  Debug.Print "時間", Timer() - st
End Sub


Public Sub test42()
  Dim rs As DAO.Recordset
  Dim rsB As DAO.Recordset
  Dim rsC As DAO.Recordset

  Dim sSql As String
  Dim oApp As Object
  Dim nTotal As Long
  Dim sFileName As String
  Dim vAry As Variant, vSub As Variant
  Dim v As Variant, vv As Variant
  Dim sS As String
  Dim i As Long, j As Long, k As Long
  Dim iEcnt As Long, iFaceNum As Long, iCnt As Long
  Dim st As Single

  Const CFILE As String = "\w_kEnt194.xls"
  Const CSQLCHK As String = "" _
          & "SELECT First(Q1.組) FROM " _
          & "T26A AS Q1 INNER JOIN T26B AS Q2 " _
          & "ON Q1.面=Q2.面 AND Q1.値=Q2.値 " _
          & "GROUP BY Q1.組 " _
          & "HAVING Count(*) >= {%1}; "
  Const CSQLINS As String = "" _
          & "INSERT INTO T26A(組, 面, 値) " _
          & "SELECT 組, 面, 値 FROM T26B;"
  Const CSQLGET As String = "" _
          & "TRANSFORM First(値) " _
          & "SELECT 組 " _
          & "FROM T26A " _
          & "GROUP BY 組 " _
          & "PIVOT 面; "
  st = Timer()

  Set oApp = CreateObject("Excel.Application")
  oApp.Workbooks.Open CurrentProject.Path & CFILE

  With oApp.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:A50")

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

  Debug.Print Timer() - st
  Randomize

  CurrentDb.Execute "DELETE * FROM T26A;"
  CurrentDb.Execute "DELETE * FROM T26B;"
  iCnt = 1
  iFaceNum = 5
  Set rsB = CurrentDb.OpenRecordset("T26B")
  Do While (1)
    iEcnt = 0
    sSql = Replace(CSQLCHK, "{%1}", iFaceNum)
    Set rsC = CurrentDb.OpenRecordset(sSql)
    While ((DCount("*", "T26A") < nTotal * (UBound(vSub) + 1)) And (iEcnt < 1000))
      CurrentDb.Execute "DELETE * FROM T26B;"
      For j = 0 To UBound(vSub)
        rsB.AddNew
        rsB("組") = iCnt
        rsB("面") = j
        rsB("値") = Int(UBound(vSub(j)) * Rnd()) + 1
        rsB.Update
      Next
      iCnt = iCnt + 1
      
      sS = ""
      rsC.Requery
      If (Not rsC.EOF) Then sS = "FOUND"
      If (Len(sS) = 0) Then CurrentDb.Execute CSQLINS
      iEcnt = iEcnt + 1
    Wend
    rsC.Close
    Debug.Print iFaceNum, DCount("*", "T26A") / (UBound(vSub) + 1), iEcnt, Timer() - st
    If (DCount("*", "T26A") >= nTotal * (UBound(vSub) + 1)) Then Exit Do
    iFaceNum = iFaceNum + 1
    If (iFaceNum > (UBound(vSub) + 1)) Then Exit Do
  Loop
  rsB.Close

  Set rs = CurrentDb.OpenRecordset(CSQLGET)
  v = rs.GetRows(nTotal)
  rs.Close
  Set rs = Nothing

  With oApp.Worksheets("Sheet2")
    .Cells.ClearContents
    With .Range("B1")
      nTotal = nTotal - 1
      If (UBound(v, 2) < nTotal) Then nTotal = UBound(v, 2)
      For i = 0 To nTotal
        sS = ""
        For j = 0 To UBound(vSub)
          sS = sS & vSub(j)(v(j + 1, i), 1)
        Next
        .Offset(i, 0) = sS
      Next
    End With
    .Range("B1:B" & nTotal + 1).Sort Key1:=.Range("B1")
    .Range("A1").Resize(nTotal + 1) = sFileName
  End With

  oApp.Visible = True
  Set oApp = Nothing
  Debug.Print "時間", Timer() - st
End Sub

 
実行速度の雰囲気は、「test41」:37秒前後  「test42」:30秒前後

これでわかるのは、「test31」「test32」の結果より、
ADO では Open / Close のオーバーヘッドが大きい・・・という事でしょうか???


以下、今まで作ってきたものでの実行結果になります。
偶々の時の結果なので・・・・乱数で得られた値による??? バラツキがあるので参考程度で

Excel

「test4」  時間: 15.42969

「test44」
除外面数生成数試行回数時間(S)
8145000 0.5859375
7475000 1.191406
61495000 1.882813
54002518 2.3125
 時間: 2.378906

「test444」
チェック面数生成数試行回数時間(S)
4125000 0.5390625
5325000 1.402344
6885000 3.5625
72945000 11.32031
8400176 12.12109
 時間: 12.19531

「test4444」
チェック面数生成数試行回数時間(S)
4125000 0.5195313
5325000 1.339844
6915000 3.347656
72985000 10.53125
8400181 11.30078
 時間: 11.69141

「test44444」
チェック面数生成数試行回数時間(S)
4125000 0.3164063
5275000 0.734375
6805000 1.738281
72715000 5.425781
8400368 6.394531
 時間: 6.675781


Access

「test」 時間  4.984375

「test2」
チェック面数生成数試行回数時間(S)
5261000 35.33594
6781000 77.72266
72531000 160.8008
840075 170.1133
 時間  170.5547

「test31」
チェック面数生成数試行回数時間(S)
5251000 12.66016
6611000 26.88672
71851000 48.43359
8400591 74.32031
 時間  74.75

「test32」
チェック面数生成数試行回数時間(S)
5221000 6.542969
6591000 13.50391
71691000 24.21875
8400532 33.67969
 時間  34.08203

「test41」
チェック面数生成数試行回数時間(S)
5221000 6.332031
6621000 13.91406
71831000 26.17969
8400514 38.28516
 時間  38.71875

「test42」
チェック面数生成数試行回数時間(S)
5231000 4.863281
6651000 10.75
71761000 20.5
8400537 29.86719
 時間  30.27344


これらの結果を見る限り、自力でゴリゴリ(Excelみたいに)やった方が速いですね・・・・

やはり、数学的なものを勉強した方が良さそう・・・・・
と言いつつ・・・ さわりだけでもやってみた

12面、面に貼り付けできる色4つ・・・・重複しないものは単純に考えて、
「111111111111」全ての面が「1」、同様に「2」~「4」の4通り

色が4つなので、4面分を1塊として、上記4通りに極力重複しない様なパターンを考えてみると
各色にバラケさした以下の24通りがありますね
項目ABCD
11234
21243
31324
41342
51423
61432
72134
82143
92314
102341
112413
122431
133124
143142
153214
163241
173412
183421
194123
204132
214213
224231
234312
244321


これを、12面分に展開・・・
単純に、1つのパターンを3つ横に展開したとすると
(「組」1~4が基本となる全部同じ値のパターン、「組」5~ が、上記で作成したもの)

kENt195_3.jpg

この図の様に、重複が「なし」「3」「6」の3パターンが現れる事に・・・
同じパターンを横3つに展開しただけなので、どうにかすれば重複数を6以下にする事が出来ると思います。
が !!!
同じところで、同じパターンは使えない・・・・これは良いでしょうか・・・
同じパターンを再度使った瞬間、4つの重複が発生する事になりますね・・・・
28組だけでも、重複数「6」を削っていくのは大変なのかな・・・・
400組で・・・ってなったら・・・

やはり・・・やっぱり、数学的なものを勉強した方が良さそう・・・・・


サンプルは以下
 バージョン 20002003 (2002)2007
 ファイル kEnt195_2000.zipkEnt195_2003.zipkEnt195_2007.zip
 サイズ 114,722116,270118,493
※ ファイルは zip 形式
※ 2007 以外は、2007 保存時に変換 & 各バージョンで動作確認 & 最適化
※ Excel ファイル w_kEnt194.xls も同梱しています

関連記事

2014/05/05

Category: やってみる

TB: --  /  CM: 0

top △

この記事に対するコメント

top △

コメントの投稿

Secret

top △


上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。