スポンサーサイト 


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

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

Excel VBA をやってみた その4 


やろうと思ったのに言うんだもんなぁ~~
ってことではないのですが、チョッと気分を削がれたところがあってブログ更新放置してました。

大したものではないのですが、せっかく用意していたものなので・・・・
(ここで停滞していたら、次、次々・・・・記事を書きにくくなるかなぁ
 ・・・サンプルファイル名にエントリ番号を使うようにしたし・・・・)


以下の様な 10 x 10 の表があります。
 ABCDEFGHIJK
1 12345678910
21 1  1 11  
32    1 1   
43      1   
54    1 1   
65      11 1
76          
87       11 
98        11
109          
1110          

縦の数字 - 横の数字 の交わるところに「1」があるところが、組合せがあることを示しています。
例えば、2行目は単純に、1 - 2、1 - 5、1 - 7、1 - 8 の組合せがあります。
ここで、2 、 5 、 7 、 8 で、組合せを考えていきます。
1 - 2 として、次の 5 を考えると 2 - 5 部分も「1」なので 1 - 2 - 5 がまず出来上がります。
1 - 2 - 5 として、次の 7 を考える時 2 - 7、5 - 7 が「1」である条件とします。
両方あるので、1 - 2 - 5 - 7 が出来上がります。
次の 8 では、2 - 8、5 - 8、7 - 8 が条件になりますが、2 - 8 が「1」ではないので候補外に。
1つできたので、次に 2 を使わない 1 - 5 から 7、8 と繰り返していきます。
これを行数分繰り返します。

結果を M2 から書き出したとすると以下の様になります。
  MNOP
1     
2 1257
3 1578
4 37  
5 457 
6 5810 
7 789 

処理の過程で出てくる組合せは、個数の多い方を有効とします。
もし、の場合で、1 - 2 - 5 - 7 があって、5 - 7 が出てきたら、1 - 2 - 5 - 7 側が有効

これをマクロ(VBA)で処理するのに、以下の関数を定義しました。
Public Sub Sample(r As Range, iNum As Integer, rr As Range)

r:どこからの表を処理しますか(上記例では Range("A1"))
iNum:何 x 何 の何(10 x 10 なら 10)
rr:結果をどこから書き出すのか(上記例では Range("M2"))
 
まずは、確認用の表を作りやすいようにコード化しておきます。
全部ではありませんが、以下の様な感じで(標準モジュール:Module1)
Dim vAry() As Variant

Private Sub MakePat1()
  vAry = Array( _
         Array(0, 1, 0, 0, 1, 0, 1, 1, 0, 0) _
        , Array(0, 0, 0, 0, 1, 0, 1, 0, 0, 0) _
        , Array(0, 0, 0, 0, 0, 0, 1, 0, 0, 0) _
        , Array(0, 0, 0, 0, 1, 0, 1, 0, 0, 0) _
        , Array(0, 0, 0, 0, 0, 0, 1, 1, 0, 1) _
        , Array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0) _
        , Array(0, 0, 0, 0, 0, 0, 0, 1, 1, 0) _
        , Array(0, 0, 0, 0, 0, 0, 0, 0, 1, 1) _
        , Array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0) _
        , Array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0) _
        )
End Sub

Public Sub TbMake10(r As Range)
  Dim i As Integer, j As Integer

  Call MakePat1
  With r
    For i = 0 To 9
      .Offset(i + 1) = i + 1
      .Offset(, i + 1) = i + 1
      For j = 0 To 9
        If (vAry(i)(j) <> 0) Then
          .Offset(i + 1, j + 1) = vAry(i)(j)
        End If
      Next
    Next
    .Value = 0
    With .CurrentRegion
      .Borders.LineStyle = xlContinuous
      .HorizontalAlignment = xlCenter
      .ColumnWidth = 2.88
    End With
    .Value = ""
    .Borders(xlDiagonalDown).LineStyle = xlContinuous
    For i = 0 To 9
      .Offset(i + 1, i + 1).Borders(xlDiagonalDown).LineStyle = xlContinuous
    Next
    .Parent.Activate
    .Select
  End With
End Sub

 
これを使って、テストパターンを作成し、実行していきます。
標準モジュール:MyGo に作成部分と、実行部分が記述してあります。
Private Const sPat1 As String = "PAT1"

Public Sub Pat1_TbMake()
  On Error GoTo ERR_HND
  With Worksheets(sPat1)
    .Range("A1", .Cells.SpecialCells(xlCellTypeLastCell)).EntireColumn.Delete
    Call TbMake10(.Range("A1"))
    Call TbMake10_2(.Range("A14"))
  End With
  Exit Sub

ERR_HND:
  If (Err.Number = 9) Then
    With Worksheets.Add(after:=Worksheets(Worksheets.Count))
      .Name = sPat1
    End With
    Resume
  End If
End Sub

Public Sub Pat1_Go()
  On Error GoTo ERR_HND
  With Worksheets(sPat1)
    .Range("M2").CurrentRegion.EntireColumn.ClearContents
    .Range("S2").CurrentRegion.EntireColumn.ClearContents
    Call Sample(.Range("A1"), 10, .Range("M2"))
    Call Sample(.Range("A1"), 7, .Range("S2"))
    Call Sample(.Range("A14"), 10, .Range("M15"))
    Call Sample(.Range("A14"), 7, .Range("S15"))
    .Range("M2").CurrentRegion.EntireColumn.AutoFit
    .Range("S2").CurrentRegion.EntireColumn.AutoFit
  End With
ERR_HND:
End Sub

 
シート「PAT1」に確認用パターンを2つ「A1」「A14」起点に作っておきます。
で、各パターンを 10 x 10、7 x 7 した結果を表示させます。
実行した結果は、以下の様になります。
kEnt140_1

・ここまでやってみてわかったこと
表を作る際に斜めの罫線を引く順番になりますが 、
1)斜めを引いてから全部・・・・なら、2000/2003 では表の全領域に斜め罫線が引かれる
2)縦横罫線引いてから斜め・・・・なら、意図通りに
まともにやろうとしたら、細かく上・下・右・左・・・を指定した罫線指定が必要みたい。

以下に処理として記述したものを書いていきますが、今回表内の「1」判別を、
数値なら・・・・にしていました。なので、「1」ではなく「2」でも同じ動きになります。

処理として記述したもの(標準モジュール:Module2)
Dim iAry() As Integer
Dim vAry As Variant

Public Sub Sample(r As Range, iNum As Integer, rr As Range)
  Dim i As Integer
  Dim vSrc As Variant

  Call DataRead(r, iNum)
  vAry = Empty
  For i = 1 To UBound(iAry, 1)
    vSrc = RowDataGet(i)
    Call ReCheck(True, vSrc, 0, Empty)
  Next
  If (Not IsEmpty(vAry)) Then
    With rr
      For i = 0 To UBound(vAry)
        .Offset(i).Resize(, UBound(vAry(i)) + 1) = vAry(i)
      Next
    End With
  End If
End Sub

Private Sub DataRead(r As Range, iNum As Integer)
  Dim rng As Range

  ReDim iAry(1 To iNum, 1 To iNum)
  For Each rng In Range(r.Offset(1, 1), r.Offset(iNum, iNum)) _
          .SpecialCells(xlCellTypeConstants, xlNumbers)
    iAry(rng.Row - r.Row, rng.Column - r.Column) = 1
  Next
End Sub

Private Function RowDataGet(iRow As Integer) As Variant
  Dim vr As Variant
  Dim i As Integer

  ReDim vr(0)
  vr(0) = iRow
  For i = 1 To UBound(iAry, 2)
    If (iAry(iRow, i) <> 0) Then
      ReDim Preserve vr(UBound(vr) + 1)
      vr(UBound(vr)) = i
    End If
  Next
  RowDataGet = vr
End Function

Private Sub DataStock(vDest As Variant)
  Dim i As Long, j As Integer, k As Integer
  Dim iCnt As Integer

  If (IsEmpty(vAry)) Then
    ReDim vAry(0)
  Else
    For i = UBound(vAry) To 0 Step -1
      If (UBound(vAry(i)) >= UBound(vDest)) Then
        iCnt = -1
        For j = 0 To UBound(vDest)
          For k = 0 To UBound(vAry(i))
            If (vAry(i)(k) = vDest(j)) Then
              iCnt = iCnt + 1
              Exit For
            End If
          Next
          If (k > UBound(vAry(i))) Then Exit For
        Next
        If (iCnt = UBound(vDest)) Then Exit Sub
      End If
    Next
    ReDim Preserve vAry(UBound(vAry) + 1)
  End If
  vAry(UBound(vAry)) = vDest
End Sub

Private Sub ReCheck(bTop As Boolean _
          , vSrc As Variant, iPos As Integer _
          , vDest As Variant)
  Dim i As Integer
  Dim v As Variant

  If (bTop) Then
    Select Case UBound(vSrc)
      Case 0
      Case 1
          Call DataStock(vSrc)
      Case Else
          ReDim v(0)
          v(0) = vSrc(0)
          Call ReCheck(False, vSrc, 1, v)
    End Select
  ElseIf (iPos > UBound(vSrc)) Then
    If (UBound(vDest) > 0) Then Call DataStock(vDest)
  Else
    For i = 1 To UBound(vDest)
      If (iAry(vDest(i), vSrc(iPos)) = 0) Then Exit For
    Next
    If (i > UBound(vDest)) Then
      v = vDest
      ReDim Preserve v(UBound(v) + 1)
      v(UBound(v)) = vSrc(iPos)
      Call ReCheck(False, vSrc, iPos + 1, v)
    End If
    Call ReCheck(False, vSrc, iPos + 1, vDest)
  End If
End Sub

 
呼ばれたら、
指定された領域で数値を持つセルを求め、配列としてメモリに展開しておきます。
行方向/列方向に1~の連番が振られていますが、それはそういうものだとして解釈しています。
1の次が2ではなく4になっていた・・・・とかは考えません。
この連番を配列で扱いやすいように、1スタートの2次元配列に・・・・
処理する行毎に、数値を持つ番号を配列に作り直します。
1行目なら、1、2、5、7、8 の配列を作って、で、これを再帰的にチェック・・・・
組合せとして成立した場合、その番号を組み込んだ配列を再生成・・・再帰処理に
組合せが成立/不成立に関わらず、今回の番号を使わない形で再帰処理に
番号を確認しきっていたら、組合せとして持っていた配列を格納するように・・・・
この時、組合せが以前のものにあった場合は格納しない様に・・・
全行処理しきったら、指定されたところへ結果を表示するように・・・・

上記では、組合せとして成立した場合、配列を作り直していましたが、
元々の配列最大を持っておいて、どこまで埋めた・・・ポインタ処理した方が速いようです。
それ用の記述が以下(標準モジュール:Module3)
Dim iAry() As Integer
Dim vAry As Variant

Public Sub Sample1(r As Range, iNum As Integer, rr As Range)
  Dim i As Integer
  Dim vSrc As Variant, vDest As Variant

  Call DataRead(r, iNum)
  vAry = Empty
  For i = 1 To UBound(iAry, 1)
    vSrc = RowDataGet(i)
    vDest = vSrc
    Call ReCheck(True, vSrc, 0, vDest, -1)
  Next
  If (Not IsEmpty(vAry)) Then
    With rr
      For i = 0 To UBound(vAry)
        .Offset(i).Resize(, UBound(vAry(i)) + 1) = vAry(i)
      Next
    End With
  End If
End Sub

Private Sub DataRead(r As Range, iNum As Integer)
  Dim rng As Range

  ReDim iAry(1 To iNum, 1 To iNum)
  For Each rng In Range(r.Offset(1, 1), r.Offset(iNum, iNum)) _
          .SpecialCells(xlCellTypeConstants, xlNumbers)
    iAry(rng.Row - r.Row, rng.Column - r.Column) = 1
  Next
End Sub

Private Function RowDataGet(iRow As Integer) As Variant
  Dim vr As Variant
  Dim i As Integer

  ReDim vr(0)
  vr(0) = iRow
  For i = 1 To UBound(iAry, 2)
    If (iAry(iRow, i) <> 0) Then
      ReDim Preserve vr(UBound(vr) + 1)
      vr(UBound(vr)) = i
    End If
  Next
  RowDataGet = vr
End Function

Private Sub DataStock(vDest As Variant, jPos As Integer)
  Dim i As Long, j As Integer, k As Integer
  Dim iCnt As Integer
  Dim v As Variant

  If (IsEmpty(vAry)) Then
    ReDim vAry(0)
  Else
    For i = UBound(vAry) To 0 Step -1
      If (UBound(vAry(i)) >= jPos) Then
        iCnt = -1
        For j = 0 To jPos
          For k = 0 To UBound(vAry(i))
            If (vAry(i)(k) = vDest(j)) Then
              iCnt = iCnt + 1
              Exit For
            End If
          Next
          If (k > UBound(vAry(i))) Then Exit For
        Next
        If (iCnt = jPos) Then Exit Sub
      End If
    Next
    ReDim Preserve vAry(UBound(vAry) + 1)
  End If
  v = vDest
  ReDim Preserve v(jPos)
  vAry(UBound(vAry)) = v
End Sub

Private Sub ReCheck(bTop As Boolean _
          , vSrc As Variant, iPos As Integer _
          , vDest As Variant, jPos As Integer)
  Dim i As Integer
  Dim v As Variant

  If (bTop) Then
    Select Case UBound(vSrc)
      Case 0
      Case 1
          Call DataStock(vSrc, 1)
      Case Else
          Call ReCheck(False, vSrc, 1, vDest, 0)
    End Select
  ElseIf (iPos > UBound(vSrc)) Then
    If (jPos > 0) Then Call DataStock(vDest, jPos)
  Else
    For i = 1 To jPos
      If (iAry(vDest(i), vSrc(iPos)) = 0) Then Exit For
    Next
    If (i > jPos) Then
      i = jPos + 1
      vDest(i) = vSrc(iPos)
      Call ReCheck(False, vSrc, iPos + 1, vDest, i)
    End If
    Call ReCheck(False, vSrc, iPos + 1, vDest, jPos)
  End If
End Sub

 

一応用意した確認のパターンには以下がありますが、
マクロの実行で、TbMake した後に Go してみてください。

・「PAT2」
 表の位置をずらしてやってみる
kEnt140_2

・「PAT3」
 30 x 30 の表でやってみる(表内のパターンは 10 x 10 の右上をコピーして)
kEnt140_3

・「PAT4」
 100 x 100 の表を作って ?? x ?? でやってみる
 また、各 ?? で行を処理する時、何個の番号の配列を何個処理したのか・・・一覧化
kEnt140_4_1  kEnt140_4_2  kEnt140_4_3
標準モジュール:MyGo に記述したのは以下で
Public Sub Pat4_Go()
  Dim rng As Range
  Dim i As Integer
  Dim iCnt As Integer
  Dim st As Single

  On Error GoTo ERR_HND
  With Worksheets(sPat4)
    iCnt = 105
    .Range("CY2").CurrentRegion.EntireColumn.ClearContents
    .Range("H104").CurrentRegion.EntireRow.Delete
    For Each rng In .Range("B2:CW2").SpecialCells(xlCellTypeConstants, xlNumbers)
      i = rng.Column - 1
      st = Timer()
      Call Sample(.Range("A1"), i, .Range("CY2"))
      st = Timer() - st
      .Range("B" & iCnt) = i & "x" & i & " マス " & Format(st, "0.000 秒")
      Call Sample2(.Range("A1"), i, .Range("H" & iCnt))
      iCnt = iCnt + 1
    Next
    With .Range("H104")
      For i = 0 To iCnt - 105
        .Offset(, i) = i
      Next
      With .CurrentRegion
        .Borders.LineStyle = xlContinuous
        .HorizontalAlignment = xlCenter
      End With
    End With
    .Range("H103") = "行数の表(横軸:1行の値の個数)"
    .Range("CY2").CurrentRegion.EntireColumn.AutoFit
  End With
ERR_HND:
End Sub

 
これをカウントする Sample2 は、Module4 で以下の様な雰囲気で
Public Sub Sample2(r As Range, iNum As Integer, rr As Range)
  Dim i As Integer, j As Integer
  Dim v As Variant
  Dim dic As Object

  Set dic = CreateObject("Scripting.Dictionary")
  Call DataRead(r, iNum)
  For i = 1 To UBound(iAry, 1)
    v = RowDataGet(i)
    j = UBound(v)
    dic.Item(j) = dic.Item(j) + 1
  Next

  For Each v In dic.Keys
    rr.Offset(, v).Value = dic.Item(v)
  Next
  Set dic = Nothing
End Sub

 
 実際にやってみた結果は kEnt140_Go.xls にそのまままとめています。
 PAT4_2007 ・・・・ 配列を作り直す方法を 2007 でやった結果
 PAT4_1_2007 ・・・・ ポインタ操作での結果 2007
 以下同様に 2000 / 2003 でやってみた結果
 ※ ポインタ操作での確認は、Sample を Sample1 に書き換える必要があります。

 表が大きく、確認する1行の番号が多くなれば、遅くなっていきますね・・・
実際に使うのだったら、想定最大時の処理速度がどれだけなのか・・・・で、他をあたるのかな
一応動いたというレベルにて・・・・

なお、zip ファイルには、
実行前の kEnt140.xls と、実行後の結果を含んだ kEnt140_Go.xls の2つが入っています。

サンプルは以下
 バージョン 2007
 ファイル kEnt140.zip
 サイズ 252,419
※ ファイルは zip 形式
※ 2007 で作成した Excel(xls) ファイル
※ 2000 / 2003 でも動作

関連記事

2012/09/23

Category: やってみる

TB: --  /  CM: 0

top △

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

top △

コメントの投稿

Secret

top △


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