Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


39316 / 76732 ←次へ | 前へ→

【42529】Re:組合せ
回答  ナイスプログラム WEB  - 06/9/13(水) 21:58 -

引用なし
パスワード
    今晩は。バグが有りました。

【問題点】
1.ソートするとrange("b1")の値が他に移動してしまう。
2.1を解決しても、シートの列が足らないので書ききれない。
3.2を解決しても、スタックが足りなくなる。

 これらの問題点を何とか解決しました。

【使い方】
前と同じ

【今後の課題】
本当に計算が合っているかどうか分らない。

【注意点】
まだバグがあるかもしれない。

*sub 記入()で使っているselectは、パソコンが動いていることを確認する
画面モニター用です。いらなければ削除してください。
*途中で止める時はCtrl + Pause

【コード】

Option Explicit
Option Base 1

Dim sinki As Object
Dim ii() As Integer
Dim index As Integer, total As Integer
Dim ir As Long, ic As Long


Sub 合計()

ThisWorkbook.Worksheets(1).Copy
Set sinki = ActiveWorkbook
total = Range("b1").Value

ReDim ii(Range("a65536").End(xlUp).Row)
ic = 4
ir = 1

Range("A1").Sort Key1:=Range("A1"), Order1:=xlDescending, Header:=xlGuess

計算2

End Sub

Private Sub 計算2()

Dim ans As Integer, i As Integer, j As Integer, rend As Integer
index = 0
i = 1
ans = total
rend = Range("a65536").End(xlUp).Row

Do
  Select Case Cells(i, 1).Value
    Case Is < ans
      index = index + 1
      ii(index) = i
      ans = ans - Cells(i, 1).Value
      
    Case ans
      index = index + 1
      ii(index) = i
      記入
      index = index - 1
      
  End Select
  i = i + 1
  
  If i > rend Then
    If ii(index) = rend Then
      Do While i > rend
        If index = 1 Then Exit Sub
        index = index - 1
        ii(index) = ii(index) + 1
        ans = total
        For j = 1 To index
          ans = ans - Cells(ii(j), 1).Value
        Next
        i = ii(index) + 1
      Loop
    Else
      ii(index) = ii(index) + 1
      If ii(index) = rend Then
        Do While i > rend
          If index = 1 Then Exit Sub
          index = index - 1
          ii(index) = ii(index) + 1
          ans = total
          For j = 1 To index
            ans = ans - Cells(ii(j), 1).Value
          Next
          i = ii(index) + 1
        Loop
      Else
        ans = total
        For j = 1 To index
          ans = ans - Cells(ii(j), 1).Value
        Next
        i = ii(index) + 1
      End If
    End If
  End If
      
Loop


End Sub


Private Sub 記入()

Dim i As Integer

For i = 1 To index
  Cells(ir, ic).Select 'モニター用
  Cells(ir, ic).Value = Cells(ii(i), 1).Value
  ir = ir + 1
Next

Cells(ir, ic).Value = "******"
ir = ir + 1

If ir > 65000 Then
  ic = ic + 1
  ir = 1
End If

End Sub

0 hits

【42432】組合せ 教えてください 06/9/11(月) 23:32 質問
【42467】Re:組合せ [名前なし] 06/9/12(火) 21:05 発言
【42471】Re:組合せ 漂流民 06/9/13(水) 0:24 発言
【42472】Re:組合せ ナイスプログラム 06/9/13(水) 1:07 回答
【42473】Re:組合せ ichinose 06/9/13(水) 6:37 発言
【42529】Re:組合せ ナイスプログラム 06/9/13(水) 21:58 回答
【42556】Re:組合せ 教えてください 06/9/14(木) 23:04 お礼

39316 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free