FC2ブログ

スポンサーサイト 


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

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

Excel VBA をやってみた その12 


moug の Excel(VBA) での問題をやってみた。
( moug の QA は6ヶ月で消えるので、アドレスは省略)

内容はというと

 ABCDEF
1111100
2111000
3111000
4000000
5000011
6100111

という 6x6 の表(データ)があった時、内容が all 0 の 2x2 の範囲でセル結合。
ただし、結合したものの個数が最大のもの(配置)を求める
つまり、以下の様な解を求める

 ABCDEF
111110
21110
311100
400
511
6100111

考え方として 2x2 の左上で、all 0 なのか・・・という情報を持っておいて、ベタで全パターンをチェック・・・

 12345
100001
200011
300011
411100
501000

1 になっている9ヶ所に関して、使う/使わない・・・チェックするので、再帰を使おうか・・・
再帰については、過去記事にもいろいろありますね「Excel VBA をやってみた その11」とか
処理数的には単純計算で、2の9乗=512回?の試行になりますが、実際には少なくさせます。

 12345
100001
200011
300011
411100
501000
 12345
100001
200000
300000
411100
501000

例えば、(2,4) を使うとした場合、その領域にかかるものを 0 にして、次の(再帰)処理・・・
2x2 での (2,4) を使うから、(2,5) と (3,3)~(3,5) を 0 に・・・
これで、何回かは削減できますね・・・
提示した Samp1 では、上記パターンで再帰関数が呼ばれたのは87回
2x2 を変更して、3x2 とかできるようにしておきましたが、回転はできない・・・
回転できるようにしたのが Samp2 ・・・

Samp2 をコピーして、個数指定をシートから取り込むようにしたのが Samp3
再帰処理を使わないで・・・ Samp4

kEnt204.jpg  kEnt204_1.jpg

再帰処理を使わない Samp4 の方が速いですね・・・って、記述が悪いのかも・・・
回転できるようにした Samp2 以降は、上記方法ではないんですけど・・・
 
Samp1 を提示した時の内容は以下
おじゃまします

チョッと興味があったのでやってみました。
ベタで全パターンやっているので速くできる所があるかも

表のどこかをクリックして、Samp1 を実行すると
ActiveCell.CurrentRegion を対象に、


Const CROWNUM As Long = 2 ' 行の個数
Const CCOLNUM As Long = 2 ' 列の個数
Const CCHECKVAL As Long = 0 ' 解釈する値

の設定に従って、求めた結果を新シートに書き出します。
上記設定では、0 の 2 x 2 を求める事になります。

※ CurrentRegion の範囲が 6 x 6 程度ならすぐかもしれない
9 x 9 とか、10 x 10 に広げていくと一気に遅くなります。
(パターンの状況にもよりますが)

Option Explicit

Const CROWNUM As Long = 2 ' 行の個数
Const CCOLNUM As Long = 2 ' 列の個数
Const CCHECKVAL As Long = 0 ' 解釈する値

Dim dic As Object, dicW As Object

Public Sub Samp1()
  Dim rng As Range
  Dim vData As Variant, vSrc As Variant
  Dim vA As Variant, vS As Variant, v As Variant
  Dim i As Long, j As Long

  Set rng = ActiveCell.CurrentRegion
  With rng
    If (.Rows.Count < CROWNUM) Then Exit Sub
    If (.Columns.Count < CCOLNUM) Then Exit Sub
    vData = .Value
    ReDim vSrc(1 To .Rows.Count - CROWNUM + 1, 1 To .Columns.Count - CCOLNUM + 1)
  End With
  For i = 1 To UBound(vSrc)
    For j = 1 To UBound(vSrc, 2)
      vSrc(i, j) = AreaCheck(vData, i, j)
    Next
  Next

  Set dic = CreateObject("Scripting.Dictionary")
  Set dicW = CreateObject("Scripting.Dictionary")
  Call ReCode(vSrc, 1, 1)
  If (dic.Count > 0) Then
    Worksheets.Add After:=ActiveSheet
    Application.DisplayAlerts = False
    With Range("A1")
      .Resize(, rng.Columns.Count).ColumnWidth = 2.5
      i = 0
      For Each vA In dic.Items
        With .Offset(i)
          rng.Copy .Cells(1)
          For Each vS In vA
            v = Split(vS, "_")
            .Cells(Int(v(0)), Int(v(1))).Resize(CROWNUM, CCOLNUM).Merge
          Next
        End With
        i = i + rng.Rows.Count + 2
      Next
    End With
    Application.DisplayAlerts = True
  End If
  Set dicW = Nothing
  Set dic = Nothing
End Sub

Private Sub ReCode(vSrc As Variant, ByVal iRow As Long, ByVal iCol As Long)
  Dim vS As Variant
  Dim sS As String
  Dim i As Long, j As Long

  While (iRow <= UBound(vSrc))
    While (iCol <= UBound(vSrc, 2))
      If (vSrc(iRow, iCol) <> 0) Then
        vS = vSrc
        sS = iRow & "_" & iCol
        dicW(sS) = Null
        Call AreaErace(vSrc, iRow, iCol)
        Call ReCode(vSrc, iRow, iCol + 1)
        dicW.Remove sS
        vS(iRow, iCol) = 0
        Call ReCode(vS, iRow, iCol + 1)
        Exit Sub
      End If
      iCol = iCol + 1
    Wend
    iRow = iRow + 1
    iCol = LBound(vSrc, 2)
  Wend

  i = dic.Count
  If (i = 0) Then
    dic(i) = dicW.Keys
  Else
    j = UBound(dic(0)) + 1
    If (dicW.Count = j) Then
      dic(i) = dicW.Keys
    ElseIf (dicW.Count > j) Then
      dic.RemoveAll
      dic(dic.Count) = dicW.Keys
    End If
  End If
End Sub

Private Function AreaCheck(vData As Variant _
        , iRow As Long, iCol As Long) As Long
  Dim i As Long, j As Long

  AreaCheck = 0
  For i = iRow To iRow + CROWNUM - 1
    For j = iCol To iCol + CCOLNUM - 1
      If (IsEmpty(vData(i, j)) _
        Or (vData(i, j) <> CCHECKVAL)) Then Exit Function
    Next
  Next
  AreaCheck = 1
End Function

Private Sub AreaErace(vSrc As Variant _
          , ByVal iRow As Long, ByVal iCol As Long)
  Dim iColMax As Long, iColMin As Long
  Dim iRowMax As Long

  iColMin = iCol - CCOLNUM + 1
  If (iColMin < LBound(vSrc, 2)) Then iColMin = LBound(vSrc, 2)
  iColMax = iCol + CCOLNUM - 1
  If (iColMax > UBound(vSrc, 2)) Then iColMax = UBound(vSrc, 2)
  iRowMax = iRow + CROWNUM - 1
  If (iRowMax > UBound(vSrc)) Then iRowMax = UBound(vSrc)

  While (iRow <= iRowMax)
    While (iCol <= iColMax)
      vSrc(iRow, iCol) = 0
      iCol = iCol + 1
    Wend
    iCol = iColMin
    iRow = iRow + 1
  Wend
End Sub

ベタな処理の概要だけですが

1,1,0,0,0,0
0,0,0,0,0,0
0,0,0,0,0,0
0,0,0,0,0,0
0,0,0,0,0,0
0,0,0,0,0,1

というデータがあった時(vData)、
2x2 左上で、all 0 の ある/なしを作っておきます(vSrc)

0,0,1,1,1
1,1,1,1,1
1,1,1,1,1
1,1,1,1,1
1,1,1,1,0

vSrc 列、行方向に <> 0 を探して、 (1,3) が見つかり、そこをまず使ってみる。
dicW にキーとして "1_3" を登録(★)
(1,3) を使う事によって、その 2x2 に重なる部分を 0 に変更

0,0,0,0,1
1,0,0,0,1
1,1,1,1,1
1,1,1,1,1
1,1,1,1,0

再帰呼び出しで同じ処理を繰り返します。
最終的に <> 0 を探せなかったら、使ってみる "行_列" が dicW にキー登録されています。
出来上がった dicW のキー情報を dic で管理します。
この時、キーは 0 ~ の連番(dic.Count)を利用し、重要な情報は Item に
dic のカウントが 0 なら、dic(0) = dicW.Keys として、キー情報を配列で Item に
dic のカウントが 0 じゃなかったら dic(0) の Item でのキー数を求めて
= なら、dic(連番) = dicW.Keys として
dicW の方が多ければ、dic を初期化して dic(0) = dicW.Keys

★ 部分で使ってみたけど、使わなかった場合について (1,3) = 0 として
使うとして登録していたキー "1_3" を削除して再帰を繰り返す

0,0,0,1,1
1,1,1,1,1
1,1,1,1,1
1,1,1,1,1
1,1,1,1,0

これでベタな全件チェックができると思います。

dic には、最大個数のものが格納されているので Items で入手後、
1件1件 "行_列" をバラして、Merge


なので、行数x列数 が大きければそれなりに遅くなります。
でも、6 x 6 限定なのであれば、ソコソコ使えるのかも


さて、ここで長方形を指定した場合、回転させて・・・ 試しておきたいかな・・・ということで
処理概略を先に

 ABCDEF
1111100
2111000
3111000
4000000
5000011
6100111

上記のデータを対象にした際、左上の情報(vSrc)は
・横長で取れる場合 =1
・縦長で取れる場合 =2
・両方取れる場合 =3
で生成します。生成されるのは以下の様な感じで

2x1123456
1000032
2000332
3000332
4333310
5133000
6010000
2x2123456
1000010
2000110
3000110
4111000
5010000
6000000

2x1 の場合、3 が 11 個、1 or 2 が、6 個
ベタな単純計算では、3^11 * 2^6 = 11337408 ?

3x1123456
1000022
2000322
3000300
4133100
5110000
6000000
3x2123456
1000020
2000320
3000100
4130000
5000000
6000000
3x3123456
1000000
2000100
3000000
4000000
5000000
6000000

4x1123456
1000022
2000200
3000000
4111000
5100000
6000000
4x2123456
1000020
2000000
3000000
4100000
5000000
6000000

※※ ベタで全件チェックするので、
※※ <> 0 の個数が多ければ多いほど、また 3 が多いほど遅くなります。

前のは回転が無かった分、vSrc 自体の更新は容易でしたが違う方法で、
vSrc と同じ領域を持つ vMask で、使っている領域を示すようにします。

3x2123456
1000020
2000320
3000100
4130000
5000000
6000000
vMask123456
10000-3-3
20000-3-3
30000-3-3
4000000
5000000
6000000

左 3x2 の vSrc の時、(1,5) を使う時、値は 2 なので縦長。
(キーは、"1_5_2" で生成)
vMask を右の様に更新
次の候補を探す時には vSrc(i,j)+vMask(i,j) > 0 のものを
(2,4) の 3 が候補に挙がりますが、値が 3 なので
・横長で取れるか
・縦長で取れるか
vMask と照合して使えないとなったら次を探します。
(2,5) は、vSrc(i,j)+vMask(i,j) > 0 ではないので対象外
候補に挙がるのは、(4,1) の 1 で、
vMask と照合して使えるとなったら、vMask を以下に更新して

3x2123456
1000020
2000320
3000100
4130000
5000000
6000000
vMask123456
10000-3-3
20000-3-3
30000-3-3
4-3-3-3000
5-3-3-3000
6000000

(4,2) は、vSrc(i,j)+vMask(i,j) > 0 ではないので対象外

dicW に登録されているキーは、"1_5_2" "4_1_1" の2つ
dicW → dic 部分には変更なく、Merge する際には、最後の _1 / _2 で方向決め

Samp2 の VBA 記述は、Samp3 とほぼ同じなので割愛
( Samp3 は、セルからマス情報を取得&時間・処理数を求める変更を入れただけ)
Option Explicit

Dim CLNUM As Long ' 長い方の個数
Dim CSNUM As Long ' 短い方の個数
Const CCHECKVAL As Long = 0 ' 解釈する値

Dim dic As Object, dicW As Object
Dim iCnt As Long

Private Sub GetNums()
  On Error Resume Next
  CLNUM = Range("O2")
  If (CLNUM < 1) Then CLNUM = 3
  CSNUM = Range("P2")
  If (CSNUM < 1) Then CSNUM = 2
  If (CLNUM < CSNUM) Then
    CLNUM = 3
    CSNUM = 2
  End If
  If (ActiveCell.Column > Range("M1").Column) Then
    Range("A1").Activate
  End If
End Sub

Public Sub Samp3()
  Dim rng As Range
  Dim vData As Variant, vSrc As Variant, vMask As Variant
  Dim vA As Variant, vS As Variant, v As Variant
  Dim i As Long, j As Long
  Dim st As Single

  st = Timer()
  Call GetNums
  Set rng = ActiveCell.CurrentRegion
  With rng
    If (.Rows.Count < CLNUM) Then Exit Sub
    If (.Columns.Count < CLNUM) Then Exit Sub
    vData = .Value
    vSrc = vData
    vMask = vData
  End With
  For i = 1 To UBound(vSrc)
    For j = 1 To UBound(vSrc, 2)
      vMask(i, j) = 0
      vSrc(i, j) = AreaCheck(vData, i, j)
    Next
  Next

  Set dic = CreateObject("Scripting.Dictionary")
  Set dicW = CreateObject("Scripting.Dictionary")
  iCnt = 0
  Call ReCode(vSrc, vMask, 1, 1)
  If (dic.Count > 0) Then
    Worksheets.Add After:=ActiveSheet
    Application.DisplayAlerts = False
    With Range("A1")
      .Resize(, rng.Columns.Count).ColumnWidth = 2.5
      i = 0
      For Each vA In dic.Items
        With .Offset(i)
          rng.Copy .Cells(1)
          For Each vS In vA
            v = Split(vS, "_")
            With .Cells(Int(v(0)), Int(v(1)))
              If (v(2) = "1") Then
                .Resize(CSNUM, CLNUM).Merge
              Else
                .Resize(CLNUM, CSNUM).Merge
              End If
            End With
          Next
        End With
        i = i + rng.Rows.Count + 2
      Next
    End With
    Application.DisplayAlerts = True
  End If
  Set dicW = Nothing
  Set dic = Nothing
  MsgBox Timer() - st & " 時間(s) iCnt = " & iCnt
End Sub

Private Sub ReCode(vSrc As Variant, vMask As Variant _
        , ByVal iRow As Long, ByVal iCol As Long)
  Dim vA As Variant, vM As Variant, v As Variant
  Dim sS As String
  Dim i As Long, j As Long
  Dim bRun As Boolean

  vA = Array(Array(1, CSNUM, CLNUM), Array(2, CLNUM, CSNUM))

  iCnt = iCnt + 1
  bRun = False
  While (iRow <= UBound(vSrc))
    While (iCol <= UBound(vSrc, 2))
      If ((vSrc(iRow, iCol) + vMask(iRow, iCol)) > 0) Then
        For Each v In vA
          If (vSrc(iRow, iCol) And v(0)) Then
            vM = vMask
            If (CheckMask(vM, iRow, iCol, v(2))) Then
              sS = iRow & "_" & iCol & "_" & v(0)
              dicW(sS) = Null
              Call SetMask(vM, iRow, iCol, v(1), v(2))
              Call ReCode(vSrc, vM, iRow, iCol + 1)
              dicW.Remove sS
              bRun = True
            End If
          End If
        Next
      End If
      iCol = iCol + 1
    Wend
    iRow = iRow + 1
    iCol = LBound(vSrc, 2)
  Wend
  If (bRun) Then Exit Sub

  If (dicW.Count > 0) Then
    i = dic.Count
    If (i = 0) Then
      dic(i) = dicW.Keys
    Else
      j = UBound(dic(0)) + 1
      If (dicW.Count = j) Then
        dic(i) = dicW.Keys
      ElseIf (dicW.Count > j) Then
        dic.RemoveAll
        dic(dic.Count) = dicW.Keys
      End If
    End If
  End If
End Sub

Private Function AreaCheck(vData As Variant _
        , iRow As Long, iCol As Long) As Long
  Dim i As Long, j As Long

  i = AreaCheckSub(vData, iRow, iCol, CSNUM, CLNUM)
  If (CLNUM = CSNUM) Then
    AreaCheck = i
    Exit Function
  End If
  j = AreaCheckSub(vData, iRow, iCol, CLNUM, CSNUM)
  AreaCheck = i + (j * 2)
End Function

Private Function AreaCheckSub(vData As Variant _
        , iRow As Long, iCol As Long _
        , iRwidth As Long, iCwidth As Long)
  Dim i As Long, j As Long

  AreaCheckSub = 0
  If ((iCol + iCwidth - 1) > UBound(vData, 2)) Then Exit Function
  If ((iRow + iRwidth - 1) > UBound(vData)) Then Exit Function
  For i = iRow To iRow + iRwidth - 1
    For j = iCol To iCol + iCwidth - 1
      If (IsEmpty(vData(i, j)) _
        Or (vData(i, j) <> CCHECKVAL)) Then Exit Function
    Next
  Next
  AreaCheckSub = 1
End Function

Private Function CheckMask(vMask As Variant _
        , iRow As Long, iCol As Long _
        , iWidth As Variant) As Boolean
  Dim i As Long

  CheckMask = False
  For i = 1 To iWidth - 1
    If (vMask(iRow, iCol + i) <> 0) Then Exit Function
  Next
  CheckMask = True
End Function

Private Sub SetMask(vMask As Variant _
        , iRow As Long, iCol As Long _
        , iRwidth As Variant, iCwidth As Variant)
  Dim i As Long, j As Long

  For i = 0 To iRwidth - 1
    For j = 0 To iCwidth - 1
      vMask(iRow + i, iCol + j) = -3
    Next
  Next
End Sub

※ 時間測定には Timer() を使っています。
 この時間には、求まったパターンを書き出す時間も含まれます。

Samp4 として、再帰を使わない、少しでも回数を減らしたいかな・・・記述に変更しています。
Option Explicit

Dim CLNUM As Long ' 長い方の個数
Dim CSNUM As Long ' 短い方の個数
Const CCHECKVAL As Long = 0 ' 解釈する値

Dim dic As Object
Dim iCallCnt As Long

Private Sub GetNums()
  On Error Resume Next
  CLNUM = Range("O2")
  If (CLNUM < 1) Then CLNUM = 3
  CSNUM = Range("P2")
  If (CSNUM < 1) Then CSNUM = 2
  If (CLNUM < CSNUM) Then
    CLNUM = 3
    CSNUM = 2
  End If
  If (ActiveCell.Column > Range("M1").Column) Then
    Range("A1").Activate
  End If
End Sub

Public Sub Samp4()
  Dim rng As Range
  Dim vData As Variant, vSrc As Variant, vMask As Variant
  Dim vA As Variant, v As Variant
  Dim i As Long, j As Long, k As Long
  Dim st As Single

  st = Timer()
  Call GetNums
  Set rng = ActiveCell.CurrentRegion
  With rng
    If (.Rows.Count < CLNUM) Then Exit Sub
    If (.Columns.Count < CLNUM) Then Exit Sub
    vData = .Value
    vMask = vData
  End With

  Set dic = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(vData)
    For j = 1 To UBound(vData, 2)
      vMask(i, j) = 0
      k = AreaCheck(vData, i, j)
      If (k > 0) Then dic(dic.Count) = Array(k, i, j)
    Next
  Next
  vSrc = dic.Items
  dic.RemoveAll

  iCallCnt = 0
  Call ReCode(vSrc, vMask)
  If (dic.Count > 0) Then
    Worksheets.Add After:=ActiveSheet
    Application.DisplayAlerts = False
    With Range("A1")
      .Resize(, rng.Columns.Count).ColumnWidth = 2.5
      i = 0
      For Each vA In dic.Items
        With .Offset(i)
          rng.Copy .Cells(1)
          v = vA(0)
          For j = 0 To vA(1) - 1
            k = v(j)(1)
            With .Cells(vSrc(k)(1), vSrc(k)(2))
              If (v(j)(0) = 1) Then
                .Resize(CSNUM, CLNUM).Merge
              Else
                .Resize(CLNUM, CSNUM).Merge
              End If
            End With
          Next
        End With
        i = i + rng.Rows.Count + 2
      Next
    End With
    Application.DisplayAlerts = True
  End If
  Set dic = Nothing
  MsgBox Timer() - st & " 時間(s) iCallCnt = " & iCallCnt
End Sub

Private Sub ReCode(ByVal vSrc As Variant, ByVal vMask As Variant)
  Dim vPosAry As Variant, vMaskAry As Variant
  Dim iSrcPos As Long, iSrcMin As Long, iSrcMax As Long
  Dim iPos As Long
  Dim vS As Variant, vM As Variant, vA As Variant, v As Variant
  Dim iMask As Long, iCnt As Long
  Dim i As Long, j As Long
  Dim bRun As Boolean

  vA = Array(Array(1, CSNUM, CLNUM), Array(2, CLNUM, CSNUM))

  iSrcMin = 0
  iSrcMax = UBound(vSrc)
  If (iSrcMax < iSrcMin) Then Exit Sub
  ReDim vPosAry(iSrcMin To iSrcMax)
  ReDim vMaskAry(iSrcMin To iSrcMax)
  iSrcPos = iSrcMin
  iPos = iSrcMin
  iCnt = 0
  bRun = True

  Do While (1)
    Do While (iSrcPos <= iSrcMax)
      vS = vSrc(iSrcPos)
      For Each v In vA
        If (bRun) Then
          iMask = vS(0) And v(0)
          If (iMask <> 0) Then
            If (CheckMask(vMask, vS(1), vS(2), v(2))) Then
              iCallCnt = iCallCnt + 1
              vPosAry(iPos) = Array(iMask, iSrcPos)
              vMaskAry(iPos) = vMask
              iPos = iPos + 1
              Call SetMask(vMask, vS(1), vS(2), v(1), v(2))
              Exit For
            End If
          End If
        End If
        bRun = True
      Next
      iSrcPos = iSrcPos + 1
    Loop

    If (iPos >= iCnt) Then
      i = dic.Count
      If (i = 0) Then
        dic(i) = Array(vPosAry, iPos)
        iCnt = iPos
      ElseIf (iPos = iCnt) Then
        dic(i) = Array(vPosAry, iPos)
      Else
        dic.RemoveAll
        dic(dic.Count) = Array(vPosAry, iPos)
        iCnt = iPos
      End If
    End If
  
    Do
      iPos = iPos - 1
      If (iPos < iSrcMin) Then Exit Sub
      iMask = vPosAry(iPos)(0)
      iSrcPos = vPosAry(iPos)(1)
      If (vSrc(iSrcPos)(0) And (iMask * 2)) Then
        vMask = vMaskAry(iPos)
        bRun = False
      ElseIf ((iPos = iSrcMin) And _
        (CLNUM * CSNUM * iCnt = UBound(vMask) * UBound(vMask, 2))) Then
        Exit Sub
      ElseIf (iSrcMax - iSrcPos + iPos >= iCnt) Then
        vMask = vMaskAry(iPos)
        iSrcPos = iSrcPos + 1
      Else
        iSrcPos = iSrcMax + 1
      End If
    Loop While (iSrcPos > iSrcMax)
  Loop
End Sub

Private Function AreaCheck(vData As Variant _
        , iRow As Long, iCol As Long) As Long
  Dim i As Long, j As Long

  i = AreaCheckSub(vData, iRow, iCol, CSNUM, CLNUM)
  If (CLNUM = CSNUM) Then
    AreaCheck = i
    Exit Function
  End If
  j = AreaCheckSub(vData, iRow, iCol, CLNUM, CSNUM)
  AreaCheck = i + (j * 2)
End Function

Private Function AreaCheckSub(vData As Variant _
        , iRow As Long, iCol As Long _
        , iRwidth As Long, iCwidth As Long)
  Dim i As Long, j As Long

  AreaCheckSub = 0
  If ((iCol + iCwidth - 1) > UBound(vData, 2)) Then Exit Function
  If ((iRow + iRwidth - 1) > UBound(vData)) Then Exit Function
  For i = iRow To iRow + iRwidth - 1
    For j = iCol To iCol + iCwidth - 1
      If (IsEmpty(vData(i, j)) _
        Or (vData(i, j) <> CCHECKVAL)) Then Exit Function
    Next
  Next
  AreaCheckSub = 1
End Function

Private Function CheckMask(vMask As Variant _
        , iRow As Variant, iCol As Variant _
        , iWidth As Variant) As Boolean
  Dim i As Long

  CheckMask = False
  For i = 0 To iWidth - 1
    If (vMask(iRow, iCol + i) <> 0) Then Exit Function
  Next
  CheckMask = True
End Function

Private Sub SetMask(vMask As Variant _
        , iRow As Variant, iCol As Variant _
        , iRwidth As Variant, iCwidth As Variant)
  Dim i As Long, j As Long

  For i = 0 To iRwidth - 1
    For j = 0 To iCwidth - 1
      vMask(iRow + i, iCol + j) = -3
    Next
  Next
End Sub

 
処理については、詳細に記述しませんが・・・
Excel VBA をやってみた その11」の処理を応用したものです。
vSrc の持ち方を大幅に変更しています。
Samp3 までは、vSrc(1 To 6, 1 To 6) の領域になっていましたが、
(方向、行、列)この配列を、配列として持つように・・・

 (0)(1)(2)
(0)215
(1)324
(2)225
(3)134
(4)141
(5)342

これの見方・参照は、vSrc(0)(2) とすると 0 番目の列の 5
これで何個を処理すれば良いのか概略分かります( UBound(vSrc)+1 が概略の個数 )
概略と言っていたのは、vSrc(x)(0) が 3 かどうか判別していないので・・・
3 の場合は、横長・縦長の2通りあるから・・・・
vSrc を作る段階で以下の様に展開しておく方が良かったのかも

 (0)(1)(2)
(0)215
(1)124
(2)224
(3)225
(4)134
(5)141
(6)142
(7)242

そう思うのは他の処理部分にも言えて
    Do
      iPos = iPos - 1
      If (iPos < iSrcMin) Then Exit Sub
      iMask = vPosAry(iPos)(0)
      iSrcPos = vPosAry(iPos)(1)
      If (vSrc(iSrcPos)(0) And (iMask * 2)) Then
        vMask = vMaskAry(iPos)
        bRun = False
      ElseIf ((iPos = iSrcMin) And _
        (CLNUM * CSNUM * iCnt = UBound(vMask) * UBound(vMask, 2))) Then
        Exit Sub
      ElseIf (iSrcMax - iSrcPos + iPos >= iCnt) Then
        vMask = vMaskAry(iPos)
        iSrcPos = iSrcPos + 1
      Else
        iSrcPos = iSrcMax + 1
      End If
    Loop While (iSrcPos > iSrcMax)
この部分は。1通りのパターンを作った後、戻りながら次候補を切り替えていく処理になります。
      If (vSrc(iSrcPos)(0) And (iMask * 2)) Then
ここで、1 を処理したけど、3 だった? 3 だったらそこからもう一度処理し直して・・・
3 を、1 と 2 に分けて作っておけば不要なものです。
また、
      ElseIf (iSrcMax - iSrcPos + iPos >= iCnt) Then
では、これから探す個数と現在候補の個数を加算してみて、今まで求まった最大パターン数以上なら・・・
という判定をしているのですが、(厳密に言えば)この記述は間違い・・・・
単に個数・・・ではなく、その中に 3 が含まれているかまでチェックしないと・・・
現状不具合的なものに出会ってませんが・・・・ 確認したパターンが悪かったんでしょう・・・
( Samp3 と Samp4 の結果が同じだったので・・・)
参考にされる方は、その辺修正してからにしてください・・・

【訂正】9/28
上記部分は勘違い。縦横方向の 3 があっても個数は1つなので修正は不要かも
なので、3 を 1 と 2 にバラして・・・と記述したあたりからのものはやめといた方が・・・
バラせば、処理するパターン数はわかりますが、今度は個数がわからなくなる?
バラす時に使っていた「個数」は、パターン数の事だった。
個数とパターン数で、ゴチャゴチャ・・・・

余談で
      ElseIf ((iPos = iSrcMin) And _
        (CLNUM * CSNUM * iCnt = UBound(vMask) * UBound(vMask, 2))) Then
部分は、1度パターンを作って戻ってきて、先頭の候補を切り替える際、
領域全部を使った解になっていたら以降の処理は不要なので抜けるように・・・
これを入れていたので、2x1 の テストパターン6 は、あの時間で終わっていたのかも・・・
この判別が無ければ、いったい・・・・・・・・

以下に測定結果を

表内の見方ですが
・「C」:結合したセルの個数
・「P」:「C」の個数での配置パターン数
左の数字はテストパターン
kEnt204.jpg
での、A~F 上から 1 ~ 4、H ~ M 上から 5 ~ 8

なお、「秒」は私の環境でのものなので、参考程度で
(サンプルファイルを実行すれば、嫌でも時間・処理数が表示されるので比較できます)

2x1CPSamp3Samp4
処理数処理数
11036 61897 2.285 18224 0.519 
215168 17019270 576.597 3889249 79.488 
315928 25669879 859.113 4678562 91.312 
41335 970710 32.757 186607 3.707 
512128 891098 30.644 194235 3.964 
6186728 292065193 5931.961 
700.003 0.003 
81613824 71833420 1829.961 

ここで、- 部分は測定する気にはならなかった・・・・ 何時間かかるんだろう
なお、テストパターン8 を確認する時には、xlsm とかに変更してから・・・
というのは、求まるパターン数が 13824 となり、表示する際の With .Offset(i) 部分でエラーになります。

2x2CPSamp3Samp4
処理数処理数
1444 0.048 30 0.042 
26320 0.095 164 0.082 
35240 0.123 161 0.117 
4454 0.046 41 0.044 
55149 0.070 102 0.070 
696427 0.302 862 0.087 
700.003 0.003 
8714 2336 0.232 1336 0.210 

ちなみに、Samp1 での処理数は以下(Samp2/Samp3 では、少し見直していたので・・・)
 処理数
187 
2639 
3479 
4107 
5297 
612853 
7
84671 


3x1CPSamp3Samp4
処理数処理数
1526 394 0.185 291 0.142 
2838 12001 0.642 6841 0.371 
3831 11339 0.628 7284 0.367 
4810 4002 0.267 2343 0.234 
572455 0.211 1503 0.140 
61264 1890557 72.634 412299 11.962 
70    
810323 374505 15.267 205125 6.820 

3x2CPSamp3Samp4
処理数処理数
1213 22 0.089 19 0.083 
2481 0.113 65 0.105 
3316 48 0.115 41 0.095 
4328 0.046 25 0.041 
5360 0.091 44 0.068 
663295 0.232 952 0.115 
70    
851092 0.152 925 0.144 

3x3CPSamp3Samp4
処理数処理数
110.039 0.035 
20    
30    
410.041 0.041 
510.064 0.052 
6460 0.046 13 0.046 
70    
8214 28 0.093 26 0.093 

4x1CPSamp3Samp4
処理数処理数
1426 0.046 19 0.042 
2564 655 0.240 489 0.238 
3516 319 0.158 266 0.138 
4433 164 0.158 131 0.142 
55198 0.115 152 0.107 
68452 38970 2.820 25182 2.117 
70    
8822 9202 0.578 5727 0.353 

4x2CPSamp3Samp4
処理数処理数
120.046 0.039 
2212 0.072 10 0.068 
320.039 0.039 
410.052 0.052 
5216 0.076 14 0.074 
6430 399 0.169 346 0.177 
70    
8340 150 0.158 137 0.119 

4x3CPSamp3Samp4
処理数処理数
10    
20    
30    
410.037 0.037 
510.044 0.046 
6218 43 0.099 41 0.103 
70    
8225 0.078 23 0.082 

4x4CPSamp3Samp4
処理数処理数
10    
20    
30    
40    
50    
6110 0.064 0.072 
70    
810.060 0.058 

5x1CPSamp3Samp4
処理数処理数
110.042 0.039 
2486 0.097 63 0.097 
3332 0.089 27 0.085 
4327 0.076 20 0.091 
5315 0.048 10 0.054 
6716 2207 0.279 1483 0.222 
70    
86437 0.169 307 0.125 

5x2CPSamp3Samp4
処理数処理数
10    
210.054 0.054 
310.042 0.041 
410.041 0.041 
510.048 0.054 
6316 85 0.111 76 0.117 
70    
8335 0.066 30 0.058 

5x3CPSamp3Samp4
処理数処理数
10    
20    
30    
40    
510.035 0.035 
6225 0.078 23 0.082 
70    
8212 0.039 10 0.039 


これらの結果より、
・6x6 を単に 9x9、12x12 にするから遅くなる・・・ ではなく、配置可能な箇所数に依存しますね。


もっと良い方法があるよ・・・ 教えてください

サンプルは以下
 バージョン 2000 でも
 ファイル kEnt204.zip
 サイズ 39,709
※ ファイルは zip 形式
※ 2007 で作成した Excel ファイル(互換:xls)


【追記】9/30
セル結合したんだけど、見難い・・・と思われたら
Samp3 / Samp4 の以下部分を変更してみてください
                .Resize(CSNUM, CLNUM).Merge
              Else
                .Resize(CLNUM, CSNUM).Merge

                With .Resize(CSNUM, CLNUM)
                  .Merge
                  .Borders.LineStyle = xlContinuous
                End With
              Else
                With .Resize(CLNUM, CSNUM)
                  .Merge
                  .Borders.LineStyle = xlContinuous
                End With


【追記:Samp4 の性能向上策】10/4
Samp4 では、1通りのパターンを作った後、戻りながら次候補を切り替えていく処理をしていました。
その時、これから探す個数と現在候補の個数を加算してみて、今まで求まった最大パターン数以上なら・・・
という判別を入れていて、それなりの効果はあったと思います。
そこで、その判別を作る過程でも・・・・
不要なパターンをチェックし続けるよりも、毎回になるけどチェックした方が・・・
総合的には速くなりましたね・・・

修正個所は、Samp4 中ほど、ReCode 関数内の以下黄色部分(1行)入れるだけです
どの程度速くなるのかは、実際に試してみてください
  Do While (1)
    Do While (iSrcPos <= iSrcMax)
      If (iSrcMax - iSrcPos + iPos + 1 < iCnt) Then Exit Do
      vS = vSrc(iSrcPos)


これをやってみて、勉強になった事

結果を新シートに作成していきますが、複数パターンがあった時には "A1" からの Offset(行) を指定
この時、"A1" のセルが結合されていた場合、結合範囲の行は 1
そのため、2つ目パターンとの間が 2 行ではなく、広がる時がある。

いやぁ~、収穫かぁ・・・・
関連記事

2014/09/27

Category: やってみる

TB: --  /  CM: 0

top △

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

top △

コメントの投稿

Secret

top △


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