| |
今晩は。バグが有りました。
【問題点】
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
|
|
ナイスプログラム
- 06/9/13(水) 21:58 -
