FC2ブログ

スポンサーサイト 


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

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

Excel VBA をやってみた その3(合計値検索) 


前の記事で完敗したものを、Excel で確認できるようにしたものです。
前の記事と言うと 再帰処理にはまる(その4 乾杯!!) になるのですが・・・・

ここで、問題を再度

テーブル「T1」があったとします。
IDF1
1381
2650
3809
4870
5765
6777
7838
8806
9133
10397
1162
12132
13415
1427
15993
16121
17348
18768
19394
20297

ここで、このデータのすべての組み合わせの中から、指定した合計の組み合わせを求めなさい。
例えば、合計が、1574 になる組み合わせは、
3, 5
2, 5, 12, 14
など

Excel でやろうとした時には、
・テーブルは関係ないし、
・ID なんて、そもそもいらない(値のみの羅列で十分)
等あって、以下の様なシートを考えてみました。
kEnt127_1  kEnt127_11  kEnt127_21
つまり、
・A列には値群
・何個使って求めるか・・・・(C1 で指定・・・・空白ならできる限り使って)
・B列に求めたい合計値を入力

で、結果は E1 以降に表示するように・・・・・
(横に展開していくのではなく、下方向に展開していくように・・・・)
(何故って・・・・2000 とか列最大数を超える組合せがあったから・・・)

ただ、合計値を入力する「行」がクセモノ( B列に限定 )
例えば、 21行目( B21 )に合計値を入力したら
A21 から前行に向かって数字じゃないものが現れるまで処理対象の値と解釈します。
(A21 数字か → はい → A20 数字か → はい → A19 数字か → ・・・・・・)
数字じゃないとか、空白ならそこで値解釈は終了・・・・ってな具合で

前回触れていませんでしたが、値は > 0 が暗黙的な前提であります。

用意したシートは「T1」「T1改」「T2」「T2改」と「パターン」の5つ
「T1」と「T2」、「T1改」と「T2改」はそれぞれVBA記述は同じもので値の記述内容が
前回 再帰処理にはまる(その4 乾杯!!) の各テーブルの「F1」(値)になっているところです。
処理的には、前回の「Module31」をベースに修正を行っています。
前回は Access のリスト表示に合わせるために、いろいろとソート云々を組み込んでいましたが、
Excel でってことなので・・・・あまり考える必要はないかな・・・・・

「T1」「T2」での表示では、
 結果表示は値を昇順に並べ替えて・・・・処理の過程等把握しやすいかな・・・・見やすいかな・・・・
「T1改」「T2改」での表示では、
 A列の並び順を尊重して横も同じ順で・・・・

って違いだけです。

なお、実行速度としては、Access でのソート処理等を省くことが出来た(?)ので
1/6 程度に短縮できたような気もします。(最終的な結果表示まで)

【追記 '14.8.26】
再帰処理ではない記述を「Excel VBA をやってみた その11」に載せました

 
シート「T1」「T2」への記述
 
VBA で記述した内容は一緒で、シート上のデータ(A列)が異なるだけです。
kEnt127_11  kEnt127_12
B列が変更された時点(Worksheet_Change)で処理を実行します。
(関数名等、前記事のものをそのまま使ったりしています。詳しくは前記事を参照してください)
Private Type AryData
  F1 As Long
  iCol As Long
  iRow As Long
End Type

Private Type PosData
  fx_pos As Long
  mv_Apos As Long
  mv_Bpos As Long
End Type

Dim iRowBase As Long
Dim iColBase As Long
Dim iMvRow As Long
Dim iMvCol As Long

Private Const sMatch As String = "○"

Private Function RecRead(iRow As Long, iCol As Long, tArySrc() As AryData) As Boolean
  Dim tTmp As AryData
  Dim i As Long, j As Long
  Dim bChg As Boolean

  RecRead = False
  j = -1
  ReDim tArySrc(0)
  For i = iRow To 1 Step -1
    If (IsEmpty(Cells(i, iCol))) Then Exit For
    If (Not IsNumeric(Cells(i, iCol))) Then Exit For
    j = j + 1
    If (j <> 0) Then ReDim Preserve tArySrc(j)
    tArySrc(j).F1 = Cells(i, iCol)
    tArySrc(j).iRow = i
    tArySrc(j).iCol = iCol
  Next
  If (j < 0) Then Exit Function

  Do
    bChg = False
    For i = 0 To j - 1
      If (tArySrc(i).F1 > tArySrc(i + 1).F1) Then
        tTmp = tArySrc(i)
        tArySrc(i) = tArySrc(i + 1)
        tArySrc(i + 1) = tTmp
        bChg = True
      ElseIf (tArySrc(i).F1 = tArySrc(i + 1).F1) Then
        If (tArySrc(i).iRow > tArySrc(i + 1).iRow) Then
          tTmp = tArySrc(i)
          tArySrc(i) = tArySrc(i + 1)
          tArySrc(i + 1) = tTmp
          bChg = True
        End If
      End If
    Next
  Loop While (bChg)
  RecRead = True
End Function

Private Sub ShowRowBase(tArySrc() As AryData)
  Dim sS As String
  Dim i As Long

  Cells(iRowBase, iColBase) = "No"
  Cells(iRowBase, iColBase + 1) = "個数"
  For i = 0 To UBound(tArySrc)
    sS = "=R[" & tArySrc(i).iRow - iRowBase & "]" _
      & "C[" & tArySrc(i).iCol - (iColBase + i + 2) & "]"
    Cells(iRowBase, iColBase + i + 2).FormulaR1C1 = sS
'    Cells(iRowBase, iColBase + i + 2) = tArySrc(i).F1
  Next
  With Range(Cells(iRowBase, iColBase + 2), Cells(iRowBase, iColBase + i + 1))
    With .Interior
      .Pattern = xlSolid
      .ColorIndex = 15
    End With
  End With
  iMvCol = iColBase + i + 1
End Sub

Private Function NextAryInfo(iNum As Long, tPosSrc As PosData, tArySrc() As AryData) As Long
  Dim i As Long

  NextAryInfo = 0
  With tPosSrc
    .mv_Apos = .mv_Apos + 1
    If (.mv_Apos > .mv_Bpos) Then Exit Function
    If (tArySrc(.mv_Apos).F1 > iNum) Then Exit Function
    While (tArySrc(.mv_Bpos).F1 > iNum)
      .mv_Bpos = .mv_Bpos - 1
    Wend
  
    i = .mv_Bpos - .mv_Apos + 1
    Select Case i
      Case 1: If (tArySrc(.mv_Apos).F1 <> iNum) Then Exit Function
      Case 2
        If (tArySrc(.mv_Apos).F1 <> iNum) Then
          If ((tArySrc(.mv_Apos).F1 + tArySrc(.mv_Bpos).F1) <> iNum) Then
            If (tArySrc(.mv_Bpos).F1 <> iNum) Then Exit Function
            .mv_Apos = .mv_Bpos
            i = 1
          End If
        End If
    End Select
    NextAryInfo = i
  End With
End Function

Private Sub ReCallSum(iNst As Long, iNum As Long _
          , tPosSrc As PosData, tArySrc() As AryData, iAryDest() As Long)
  Dim tPosWsrc As PosData, tPosToSrc As PosData
  Dim iNumNew As Long
  Dim i As Long, j As Long

  If (iNst < 1) Then Exit Sub
  With tPosSrc
    j = 0
    For i = .mv_Apos To .mv_Bpos
      j = j + tArySrc(i).F1
    Next
  End With
  If ((j = 0) Or (iNum > j)) Then Exit Sub

  tPosWsrc = tPosSrc
  With tPosWsrc
    .fx_pos = .fx_pos + 1
    Do While (.mv_Apos <= .mv_Bpos)
      iNumNew = iNum - tArySrc(.mv_Apos).F1
      If (iNumNew < 0) Then Exit Do
      iAryDest(.fx_pos) = .mv_Apos
      If (iNumNew = 0) Then
        If (iRowBase = iMvRow) Then Call ShowRowBase(tArySrc)
        iMvRow = iMvRow + 1
        Cells(iMvRow, iColBase) = iMvRow - iRowBase
        For i = 0 To .fx_pos
          Cells(iMvRow, iColBase + iAryDest(i) + 2) = sMatch
        Next
        Cells(iMvRow, iColBase + 1).FormulaR1C1 = _
          "=COUNTIF(RC[1]:RC[" & iMvCol - (iColBase + 1) & "],""" & sMatch & """)"
      ElseIf (iNst > 1) Then
        tPosToSrc = tPosWsrc
        If (NextAryInfo(iNumNew, tPosToSrc, tArySrc) <> 0) Then
          Call ReCallSum(iNst - 1, iNumNew, tPosToSrc, tArySrc, iAryDest)
        End If
      End If
      .mv_Apos = .mv_Apos + 1
    Loop
  End With
End Sub

Private Sub SumSearch(iNst As Long, iRow As Long, iCol As Long, iNum As Long)
  Dim tArySrc() As AryData
  Dim iAryDest() As Long
  Dim tPosSrc As PosData
  Dim i As Long

  If (Not RecRead(iRow, iCol, tArySrc)) Then Exit Sub
  ReDim iAryDest(UBound(tArySrc))
  With tPosSrc
    .fx_pos = -1
    .mv_Apos = 0
    .mv_Bpos = UBound(tArySrc)
  End With
  Call ReCallSum(iNst, iNum, tPosSrc, tArySrc, iAryDest)
  If (iRowBase <> iMvRow) Then
    For i = iRowBase + 1 To iMvRow
      If ((i Mod 2) = 0) Then
        With Range(Cells(i, iColBase), Cells(i, iMvCol)).Interior
          .Pattern = xlSolid
          .ColorIndex = 36
        End With
      End If
    Next
    With Range(Cells(iRowBase, iColBase), Cells(iMvRow, iMvCol))
      With .Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
      End With
      .HorizontalAlignment = xlCenter
      .EntireColumn.AutoFit
    End With
  End If
End Sub

Private Sub SheetInit(iRow As Long, iCol As Long)
  Dim i As Long, j As Long, k As Long

  i = iRow - 1
  If (i < 1) Then i = 1
  j = iCol - 1
  If (j < 1) Then j = 1
  With Cells.SpecialCells(xlCellTypeLastCell)
    k = .Column
    If (k < iCol) Then k = iCol
    Range(Cells(i, j), Cells(.Row, k)).Clear
  End With
  iColBase = iCol
  iRowBase = iRow
  iMvRow = iRowBase
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
  Dim iNum As Long, iNst As Long

  On Error Resume Next
  If (Target.Count <> 1) Then Exit Sub
  If (Target.Column <> 2) Then Exit Sub
  iNum = Target
  If (iNum <= 0) Then Exit Sub
  If (IsEmpty(Target.Offset(0, -1))) Then Exit Sub
  iNst = Cells(1, 3)
  If (iNst <= 0) Then iNst = Target.Row

  Application.EnableEvents = False
  Application.ScreenUpdating = False

  Call SheetInit(1, 5)
  Call SumSearch(iNst, Target.Row, 1, iNum)
  Target.Select

  Application.ScreenUpdating = True
  Application.EnableEvents = True
End Sub

 

シート「T1改」「T2改」への記述
 
VBA で記述した内容は一緒で、シート上のデータ(A列)が異なるだけです。
また、「T1」「T2」と異なるのは、結果を表示する際の値の並び順だけになります。
kEnt127_21  kEnt127_22
B列が変更された時点(Worksheet_Change)で処理を実行します。
(「T1」「T2」記述をベースに異なった部分を黄色表示で)
Private Type AryData
  F1 As Long
  ID As Long
  iCol As Long
  iRow As Long
End Type

Private Type PosData
  fx_pos As Long
  mv_Apos As Long
  mv_Bpos As Long
End Type

Dim iRowBase As Long
Dim iColBase As Long
Dim iMvRow As Long
Dim iMvCol As Long

Private Const sMatch As String = "○"

Private Function RecRead(iRow As Long, iCol As Long, tArySrc() As AryData) As Boolean
  Dim tTmp As AryData
  Dim i As Long, j As Long
  Dim bChg As Boolean

  RecRead = False
  j = -1
  ReDim tArySrc(0)
  For i = iRow To 1 Step -1
    If (IsEmpty(Cells(i, iCol))) Then Exit For
    If (Not IsNumeric(Cells(i, iCol))) Then Exit For
    j = j + 1
    If (j <> 0) Then ReDim Preserve tArySrc(j)
    tArySrc(j).F1 = Cells(i, iCol)
    tArySrc(j).ID = -j
    tArySrc(j).iRow = i
    tArySrc(j).iCol = iCol
  Next
  If (j < 0) Then Exit Function

  For i = 0 To j
    tArySrc(i).ID = tArySrc(i).ID + j
  Next

  Do
    bChg = False
    For i = 0 To j - 1
      If (tArySrc(i).F1 > tArySrc(i + 1).F1) Then
        tTmp = tArySrc(i)
        tArySrc(i) = tArySrc(i + 1)
        tArySrc(i + 1) = tTmp
        bChg = True
      ElseIf (tArySrc(i).F1 = tArySrc(i + 1).F1) Then
        If (tArySrc(i).iRow > tArySrc(i + 1).iRow) Then
          tTmp = tArySrc(i)
          tArySrc(i) = tArySrc(i + 1)
          tArySrc(i + 1) = tTmp
          bChg = True
        End If
      End If
    Next
  Loop While (bChg)
  RecRead = True
End Function

Private Sub ShowRowBase(tArySrc() As AryData)
  Dim sS As String
  Dim i As Long, j As Long

  Cells(iRowBase, iColBase) = "No"
  Cells(iRowBase, iColBase + 1) = "個数"
  For i = 0 To UBound(tArySrc)
    j = tArySrc(i).ID
    sS = "=R[" & tArySrc(i).iRow - iRowBase & "]" _
      & "C[" & tArySrc(i).iCol - (iColBase + j + 2) & "]"
    Cells(iRowBase, iColBase + j + 2).FormulaR1C1 = sS
'    Cells(iRowBase, iColBase + j + 2) = tArySrc(i).F1
  Next
  With Range(Cells(iRowBase, iColBase + 2), Cells(iRowBase, iColBase + i + 1))
    With .Interior
      .Pattern = xlSolid
      .ColorIndex = 15
    End With
  End With
  iMvCol = iColBase + i + 1
End Sub

Private Function NextAryInfo(iNum As Long, tPosSrc As PosData, tArySrc() As AryData) As Long
  Dim i As Long

  NextAryInfo = 0
  With tPosSrc
    .mv_Apos = .mv_Apos + 1
    If (.mv_Apos > .mv_Bpos) Then Exit Function
    If (tArySrc(.mv_Apos).F1 > iNum) Then Exit Function
    While (tArySrc(.mv_Bpos).F1 > iNum)
      .mv_Bpos = .mv_Bpos - 1
    Wend
  
    i = .mv_Bpos - .mv_Apos + 1
    Select Case i
      Case 1: If (tArySrc(.mv_Apos).F1 <> iNum) Then Exit Function
      Case 2
        If (tArySrc(.mv_Apos).F1 <> iNum) Then
          If ((tArySrc(.mv_Apos).F1 + tArySrc(.mv_Bpos).F1) <> iNum) Then
            If (tArySrc(.mv_Bpos).F1 <> iNum) Then Exit Function
            .mv_Apos = .mv_Bpos
            i = 1
          End If
        End If
    End Select
    NextAryInfo = i
  End With
End Function

Private Sub ReCallSum(iNst As Long, iNum As Long _
          , tPosSrc As PosData, tArySrc() As AryData, iAryDest() As Long)
  Dim tPosWsrc As PosData, tPosToSrc As PosData
  Dim iNumNew As Long
  Dim i As Long, j As Long

  If (iNst < 1) Then Exit Sub
  With tPosSrc
    j = 0
    For i = .mv_Apos To .mv_Bpos
      j = j + tArySrc(i).F1
    Next
  End With
  If ((j = 0) Or (iNum > j)) Then Exit Sub

  tPosWsrc = tPosSrc
  With tPosWsrc
    .fx_pos = .fx_pos + 1
    Do While (.mv_Apos <= .mv_Bpos)
      iNumNew = iNum - tArySrc(.mv_Apos).F1
      If (iNumNew < 0) Then Exit Do
      iAryDest(.fx_pos) = .mv_Apos
      If (iNumNew = 0) Then
        If (iRowBase = iMvRow) Then Call ShowRowBase(tArySrc)
        iMvRow = iMvRow + 1
        Cells(iMvRow, iColBase) = iMvRow - iRowBase
        For i = 0 To .fx_pos
          Cells(iMvRow, iColBase + tArySrc(iAryDest(i)).ID + 2) = sMatch
        Next
        Cells(iMvRow, iColBase + 1).FormulaR1C1 = _
          "=COUNTIF(RC[1]:RC[" & iMvCol - (iColBase + 1) & "],""" & sMatch & """)"
      ElseIf (iNst > 1) Then
        tPosToSrc = tPosWsrc
        If (NextAryInfo(iNumNew, tPosToSrc, tArySrc) <> 0) Then
          Call ReCallSum(iNst - 1, iNumNew, tPosToSrc, tArySrc, iAryDest)
        End If
      End If
      .mv_Apos = .mv_Apos + 1
    Loop
  End With
End Sub

Private Sub SumSearch(iNst As Long, iRow As Long, iCol As Long, iNum As Long)
  Dim tArySrc() As AryData
  Dim iAryDest() As Long
  Dim tPosSrc As PosData
  Dim i As Long

  If (Not RecRead(iRow, iCol, tArySrc)) Then Exit Sub
  ReDim iAryDest(UBound(tArySrc))
  With tPosSrc
    .fx_pos = -1
    .mv_Apos = 0
    .mv_Bpos = UBound(tArySrc)
  End With
  Call ReCallSum(iNst, iNum, tPosSrc, tArySrc, iAryDest)
  If (iRowBase <> iMvRow) Then
    For i = iRowBase + 1 To iMvRow
      If ((i Mod 2) = 0) Then
        With Range(Cells(i, iColBase), Cells(i, iMvCol)).Interior
          .Pattern = xlSolid
          .ColorIndex = 36
        End With
      End If
    Next
    With Range(Cells(iRowBase, iColBase), Cells(iMvRow, iMvCol))
      With .Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
      End With
      .HorizontalAlignment = xlCenter
      .EntireColumn.AutoFit
    End With
  End If
End Sub

Private Sub SheetInit(iRow As Long, iCol As Long)
  Dim i As Long, j As Long, k As Long

  i = iRow - 1
  If (i < 1) Then i = 1
  j = iCol - 1
  If (j < 1) Then j = 1
  With Cells.SpecialCells(xlCellTypeLastCell)
    k = .Column
    If (k < iCol) Then k = iCol
    Range(Cells(i, j), Cells(.Row, k)).Clear
  End With
  iColBase = iCol
  iRowBase = iRow
  iMvRow = iRowBase
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
  Dim iNum As Long, iNst As Long

  On Error Resume Next
  If (Target.Count <> 1) Then Exit Sub
  If (Target.Column <> 2) Then Exit Sub
  iNum = Target
  If (iNum <= 0) Then Exit Sub
  If (IsEmpty(Target.Offset(0, -1))) Then Exit Sub
  iNst = Cells(1, 3)
  If (iNst <= 0) Then iNst = Target.Row

  Application.EnableEvents = False
  Application.ScreenUpdating = False

  Call SheetInit(1, 5)
  Call SumSearch(iNst, Target.Row, 1, iNum)
  Target.Select

  Application.ScreenUpdating = True
  Application.EnableEvents = True
End Sub

 
さほど変更箇所はありません。

なお、「T2」「T2改」で確認する際は、指定する値に注意してください。
合計値 4500 を指定すると、8分弱で 39483 組・・・・・
安易に値を入力すると悲惨な目にあいます・・・・・
4200 の時が 3分チョッとだったから・・・・・・ どんな感じで時間は膨れていくのでしょうか ??

大きな値を指定したい時には、まず、使用個数を小さくしてから実行してみてください。


あ、そうそう
Excel 化にあたって、前回の Access 版より大きく変更した点があって
Dest 部分に格納する方法・・・・・・

Dest には Src の配列番号のみを格納するように変更しました。
現在解釈中のものを示すことに大差はなく、なんか軽そうだったので・・・・

サンプルは以下
 バージョン 2000
 ファイル kEnt127.zip
 サイズ 18,167
※ ファイルは zip 形式
※ 2000 で作成した Excel ファイル

関連記事

2012/04/25

Category: やってみる

TB: 0  /  CM: 0

top △

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

top △

コメントの投稿

Secret

top △

トラックバック

トラックバックURL
→http://kikutips.blog13.fc2.com/tb.php/127-70321b35
この記事にトラックバックする(FC2ブログユーザー)

top △


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