～ kiku tips ～

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

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

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

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

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