Excel VBA をやってみた その10 Vol.2
この記事は、「Excel VBA をやってみた その10」の続編です。
1度そちらを参照されてから読まれたらと思います。
内容としては、多面体に色を割付ける時、重複するパターンを少なく割付けていくには・・・・
その記事で、サンプルファイルに入れていなかったVBA記述等、今回のサンプルファイルに盛り込んでいます。
また、もう少し Excel 側の記述を確かめています。
その中には、
今まで「A」「B」~「L」の順で確認していたものを、順をローテーションさせた出力もしています。


条件付き書式で、パターンを探してみると「重複」とは何ぞや・・・・ が疑問になるかも・・・・・・
重複を減らす・・・・ 各面の色数を増やす方向のアプローチもありなのかなぁ??
今回のサンプルファイルには、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
↓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」もそれなりに変更・・・・
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
また、求めたい数が全パターン数以上なら全パターン分返す処理部分を見直し
If (j <= nTotal) Then
If (i = 1) Then
vDic = vChk(0)
Else
Exit Sub
End If
↓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)
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
.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
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 に
素直にやるとすれば、以下の様な感じ?
でも、配列を Variant で持てば、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
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
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
& "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));
になります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
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
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}部分は、即値に置換えて実行します。& "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}; "
つまり、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
& "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
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レコード、列(フィールド)側を「面」で・・・
列の並びを考えないといけないのは、文字列として作成される場合です。
例えば、
配列で値を入手しやすいようにクロス集計で、「組」・・・1レコード、列(フィールド)側を「面」で・・・
Const CSQLGET As String = "" _
& "TRANSFORM First(値) " _
& "SELECT 組 " _
& "FROM T26A " _
& "GROUP BY 組 " _
& "PIVOT 面; "
PIVOT 面 ・・・・ としているので、作成される列(フィールド)は数値の昇順に並んでくれます& "TRANSFORM First(値) " _
& "SELECT 組 " _
& "FROM T26A " _
& "GROUP BY 組 " _
& "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}; "
& "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
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
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) |
---|---|---|---|
8 | 14 | 5000 | 0.5859375 |
7 | 47 | 5000 | 1.191406 |
6 | 149 | 5000 | 1.882813 |
5 | 400 | 2518 | 2.3125 |
「test444」
チェック面数 | 生成数 | 試行回数 | 時間(S) |
---|---|---|---|
4 | 12 | 5000 | 0.5390625 |
5 | 32 | 5000 | 1.402344 |
6 | 88 | 5000 | 3.5625 |
7 | 294 | 5000 | 11.32031 |
8 | 400 | 176 | 12.12109 |
「test4444」
チェック面数 | 生成数 | 試行回数 | 時間(S) |
---|---|---|---|
4 | 12 | 5000 | 0.5195313 |
5 | 32 | 5000 | 1.339844 |
6 | 91 | 5000 | 3.347656 |
7 | 298 | 5000 | 10.53125 |
8 | 400 | 181 | 11.30078 |
「test44444」
チェック面数 | 生成数 | 試行回数 | 時間(S) |
---|---|---|---|
4 | 12 | 5000 | 0.3164063 |
5 | 27 | 5000 | 0.734375 |
6 | 80 | 5000 | 1.738281 |
7 | 271 | 5000 | 5.425781 |
8 | 400 | 368 | 6.394531 |
Access
「test」 時間 4.984375
「test2」
チェック面数 | 生成数 | 試行回数 | 時間(S) |
---|---|---|---|
5 | 26 | 1000 | 35.33594 |
6 | 78 | 1000 | 77.72266 |
7 | 253 | 1000 | 160.8008 |
8 | 400 | 75 | 170.1133 |
「test31」
チェック面数 | 生成数 | 試行回数 | 時間(S) |
---|---|---|---|
5 | 25 | 1000 | 12.66016 |
6 | 61 | 1000 | 26.88672 |
7 | 185 | 1000 | 48.43359 |
8 | 400 | 591 | 74.32031 |
「test32」
チェック面数 | 生成数 | 試行回数 | 時間(S) |
---|---|---|---|
5 | 22 | 1000 | 6.542969 |
6 | 59 | 1000 | 13.50391 |
7 | 169 | 1000 | 24.21875 |
8 | 400 | 532 | 33.67969 |
「test41」
チェック面数 | 生成数 | 試行回数 | 時間(S) |
---|---|---|---|
5 | 22 | 1000 | 6.332031 |
6 | 62 | 1000 | 13.91406 |
7 | 183 | 1000 | 26.17969 |
8 | 400 | 514 | 38.28516 |
「test42」
チェック面数 | 生成数 | 試行回数 | 時間(S) |
---|---|---|---|
5 | 23 | 1000 | 4.863281 |
6 | 65 | 1000 | 10.75 |
7 | 176 | 1000 | 20.5 |
8 | 400 | 537 | 29.86719 |
これらの結果を見る限り、自力でゴリゴリ(Excelみたいに)やった方が速いですね・・・・
やはり、数学的なものを勉強した方が良さそう・・・・・
と言いつつ・・・ さわりだけでもやってみた
12面、面に貼り付けできる色4つ・・・・重複しないものは単純に考えて、
「111111111111」全ての面が「1」、同様に「2」~「4」の4通り
色が4つなので、4面分を1塊として、上記4通りに極力重複しない様なパターンを考えてみると
各色にバラケさした以下の24通りがありますね
項目 | A | B | C | D |
---|---|---|---|---|
1 | 1 | 2 | 3 | 4 |
2 | 1 | 2 | 4 | 3 |
3 | 1 | 3 | 2 | 4 |
4 | 1 | 3 | 4 | 2 |
5 | 1 | 4 | 2 | 3 |
6 | 1 | 4 | 3 | 2 |
7 | 2 | 1 | 3 | 4 |
8 | 2 | 1 | 4 | 3 |
9 | 2 | 3 | 1 | 4 |
10 | 2 | 3 | 4 | 1 |
11 | 2 | 4 | 1 | 3 |
12 | 2 | 4 | 3 | 1 |
13 | 3 | 1 | 2 | 4 |
14 | 3 | 1 | 4 | 2 |
15 | 3 | 2 | 1 | 4 |
16 | 3 | 2 | 4 | 1 |
17 | 3 | 4 | 1 | 2 |
18 | 3 | 4 | 2 | 1 |
19 | 4 | 1 | 2 | 3 |
20 | 4 | 1 | 3 | 2 |
21 | 4 | 2 | 1 | 3 |
22 | 4 | 2 | 3 | 1 |
23 | 4 | 3 | 1 | 2 |
24 | 4 | 3 | 2 | 1 |
これを、12面分に展開・・・
単純に、1つのパターンを3つ横に展開したとすると
(「組」1~4が基本となる全部同じ値のパターン、「組」5~ が、上記で作成したもの)

この図の様に、重複が「なし」「3」「6」の3パターンが現れる事に・・・
同じパターンを横3つに展開しただけなので、どうにかすれば重複数を6以下にする事が出来ると思います。
が !!!
同じところで、同じパターンは使えない・・・・これは良いでしょうか・・・
同じパターンを再度使った瞬間、4つの重複が発生する事になりますね・・・・
28組だけでも、重複数「6」を削っていくのは大変なのかな・・・・
400組で・・・ってなったら・・・
やはり・・・やっぱり、数学的なものを勉強した方が良さそう・・・・・
サンプルは以下 | ||||||||||||
| ||||||||||||
※ ファイルは zip 形式 | ||||||||||||
※ 2007 以外は、2007 保存時に変換 & 各バージョンで動作確認 & 最適化 | ||||||||||||
※ Excel ファイル w_kEnt194.xls も同梱しています |
- 関連記事
-
- 再帰処理にはまる(その1) (2012/03/12)
- ラベルでゴニョゴニョ (2012/08/04)
- 更新した内容を全て元に戻す (2011/12/12)
- フィールドの順って (2011/05/22)
- 再帰処理にはまる(その4 乾杯!!) (2012/04/20)
- フィールド順 Table 編 (2011/05/29)
- Excel VBA をやってみた その5 (2012/10/10)
- 再帰処理にはまる(その5) (2013/05/06)
- フィールド順 TableDef 編 (2011/05/29)
- Excel へのデータ転記 (2013/05/28)
- 重ねる (2012/05/16)
- ListIndex の怪? (2013/09/28)
- Excel VBA をやってみた その10 Vol.2 (2014/05/05)
2014/05/05
Category: やってみる
TB: -- /
CM: 0
この記事に対するコメント
| h o m e |