麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] [求助] VBA 比對後持續相減問題 [打印本頁]

作者: sabery 時間: 2015-4-11 20:45 標題: [求助] VBA 比對後持續相減問題

EXCEL A 頁
有兩名同學與每日花費
[attach]20627[/attach]

EXCEL B 頁
兩名同學存款
[attach]20628[/attach]

VB寫法

Sub TEST()

Dim i As Integer
Dim j As Integer

Sheets("A").Select

   i = 3

Do While Range("B" & i) <> ""

   j = 3

Do While Sheets("B").Range("A" & j) <> ""
      If Range("B" & i) = Sheets("B").Range("A" & j) Then
         Range("D" & i) = Sheets("B").Range("B" & j) - Sheets("A").Range("C" & i)
Exit Do
      End If
         j = j + 1
  Loop
         i = i + 1
Loop

MsgBox " TEST! "

End Sub
問題點他只會比對後使用存款相減當日花費並不會連續相減
例如小明存款 5000 ( 1/30 小明花費 300 ) ( 存款5000 - 300 = 4700 ) 具續比對 2/13 小明花費 200 ( 存款 5000 - 200 = 4800 )

請教各位高手
指導一下希望可以改成
例如小明存款 5000 ( 1/30 小明花費 300 ) ( 存款5000 - 300 = 4700 ) 具續比對 2/13 小明花費 200 ( 存款 4700 - 200 = 4500 )

懊惱許久，一直無法解決。。。
煩請指導一下 !

作者: lpk187 時間: 2015-4-11 23:02

回復 1# sabery

Sub TEST()
Dim i As Integer
Dim j As Integer
j = 5
Do While Sheets("B").Range("A" & j) <> ""
i = 6
Do While Range("B" & i) <> ""
If Range("B" & i) = Sheets("B").Range("A" & j) Then
B = Sheets("A").Range("C" & i) + B
Range("D" & i) = Sheets("B").Range("B" & j) - B
End If
i = i + 1
Loop
B = 0
j = j + 1
Loop
MsgBox " TEST! "
End Sub

複製代碼

作者: sabery 時間: 2015-4-12 01:06

回復 2# lpk187

非常感謝幫助..
可是結果似乎不太正確 !!
[attach]20630[/attach]
王小明第二次花費變成負數 ...

作者: sabery 時間: 2015-4-12 01:28

回復 sabery
lpk187 發表於 2015-4-11 23:02

非常感謝版大 !!
已知道問題點在哪邊 !!

作者: sabery 時間: 2015-4-12 05:09

本帖最後由 sabery 於 2015-4-12 05:11 編輯

回復 sabery
lpk187 發表於 2015-4-11 23:02

         If Range("D" & i) < 0 Then
            Range("D" & i).Interior.Color = vbRed
            Else
            Range("D" & i).Font.Color = vbBlack
            End If

版大再次請教下 !!
今天假如想把負數找出來我文中這樣寫只有單獨把 Range("M" & i) 該格反紅如何把整行反紅呢 !!
不好意思新手上路真的真的請多耐心指導 !!

作者: sabery 時間: 2015-4-12 05:38

回復 sabery
lpk187 發表於 2015-4-11 23:02

目前是有用最笨方法
If Range("D" & i) < 0 Then
            Range("A" & i).Interior.Color = vbRed
            Range("B" & i).Interior.Color = vbRed
            Range("C" & i).Interior.Color = vbRed
            Range("D" & i).Interior.Color = vbRed
            Else
            Range("A" & i).Interior.Color = vbWhite
            Range("B" & i).Interior.Color = vbWhite
            Range("C" & i).Interior.Color = vbWhite
            Range("D" & i).Interior.Color = vbWhite
            End If

不知道有沒有更好方式!?
因為背景換色導致線不見了

作者: lpk187 時間: 2015-4-12 23:05

回復 6# sabery
呃！我不是版大，我也只是個新學員而已！:P
試試這個

For Each arng In Range("D6:D" & Cells(Rows.Count, "D").End(xlUp).Row)
If arng < 0 Then
With Range(Cells(arng.Row, 1), Cells(arng.Row, Columns.Count).End(xlToLeft).Address).Interior
.Color = vbRed
End With
Else
With Range(Cells(arng.Row, 1), Cells(arng.Row, Columns.Count).End(xlToLeft).Address).Interior
.Color = vbWhite
End With
End If
Next

複製代碼

作者: sabery 時間: 2015-4-15 05:20

本帖最後由 sabery 於 2015-4-15 05:21 編輯

回復 sabery
呃！我不是版大，我也只是個新學員而已！
試試這個
lpk187 發表於 2015-4-12 23:05

不好意思版大最後一問假使
今天增加一新同學
王小智
[attach]20651[/attach]

可是存款卻沒有他的資料
[attach]20650[/attach]

希望在D出現負數不夠存款所以顯示
例如
2015/02/13
呂曉智 200 D欄 = 不夠
2015/02/26
呂曉智 400 D欄 = 不夠
這樣寫

Sub TEST()
Dim i As Integer
Dim j As Integer
Dim B As Long
Sheets("A").Select
j = 5
Do While Sheets("B").Range("A" & j) <> ""
i = 6
Do While Range("B" & i) <> ""
If Range("B" & i) = Sheets("B").Range("A" & j) Then
B = Sheets("A").Range("C" & i) + B
Range("D" & i) = Sheets("B").Range("B" & j) - B
ElseIf Range("B" & i) <> Sheets("B").Range("A" & j) Then
Range("D" & i) = "不夠"
End If
i = i + 1
Loop
B = 0
j = j + 1
Loop
MsgBox " TEST! "
End Sub

複製代碼

可是錯誤連王小明都跑掉 !
可以再次指導嗎? 拜託了.

作者: lpk187 時間: 2015-4-15 20:25

本帖最後由 lpk187 於 2015-4-15 20:26 編輯

回復 8# sabery

程序中條件不同，整體的程序也會跟著大變動的，不一定是你從中間插入就可以完成的。
原來的那個程序和你前面的條件相差太多，所以整個結構也很難相同
所以我又想了新增條件的新結構和之前的不同

Sub TEST2()
Dim i As Integer
Sheets("A").Select
i = 6
Do While Range("B" & i) <> ""
SSS = Range("B" & i) '觀察變數用,可以刪除這列
If Range("D" & i) <> "" Then GoTo 100
Set c = Sheets("B").Columns(1).Find(Range("B" & i), , , , , 2) '尋找是否在存款中有帳戶
If c Is Nothing Then '如果沒有就執行這個程序
Range("D" & i) = "不夠"
GoTo 100
End If
QQQ = c.Offset(0, 1).Value '讀取工作表"B"某人的存款
AAA = QQQ - Range("C" & i) '某人的存款-第一次花費
Range("D" & i) = AAA
Set DepRow = Columns(2).Find(Range("B" & i), Range("B" & i), , , , 1) '尋找下一個某人的花費
Do While DepRow.Offset(0, 2).Value = "" '一直尋找某人的花費,直到找不到為止
AAA = AAA - DepRow.Offset(0, 1)
DepRow.Offset(0, 2) = AAA
Set DepRow = Columns(2).FindNext(DepRow)
BBB = DepRow.Row '觀察變數用,可以刪除這列
Loop
100: '重新還原變數值
AAA = ""
i = i + 1
Set c = Nothing
Loop
MsgBox " TEST! "
End Sub

複製代碼

作者: lpk187 時間: 2015-4-15 20:31

回復 8# sabery

下面是我執行的結果
B工作表
[attach]20663[/attach]
A工作表
[attach]20662[/attach]

作者: sabery 時間: 2015-4-16 02:59

回復 sabery

下面是我執行的結果
B工作表

A工作表
lpk187 發表於 2015-4-15 20:31

太強了 ...
因為是興趣想自學! 當初學校有教過一點點 .
不知道版大也是嗎? 還是有去上過呢 ?

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)