[發問] [求助] VBA 比對後持續相減 問題

sabery

EXCEL A 頁
有兩名同學 與 每日花費

下載 (40.59 KB)

2015-4-11 20:43

EXCEL B 頁
兩名同學存款

下載 (20.06 KB)

2015-4-11 20:43

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

回復 1# sabery

1. Sub TEST()
   
2. Dim i As Integer
   
3. Dim j As Integer
   
4.        j = 5
   
5.     Do While Sheets("B").Range("A" & j) <> ""
   
6.            i = 6
   
7.         Do While Range("B" & i) <> ""
   
8.             If Range("B" & i) = Sheets("B").Range("A" & j) Then
   
9.                 B = Sheets("A").Range("C" & i) + B
   
10.                Range("D" & i) = Sheets("B").Range("B" & j) - B
    
11.             End If
    
12.                 i = i + 1
    
13.         Loop
    
14.                 B = 0
    
15.                 j = j + 1
    
16.     Loop
    
17. MsgBox " TEST! "
    
18. End Sub

複製代碼

sabery

回復 2# lpk187

非常感謝幫助..
可是結果似乎不太正確 !!

下載 (21.28 KB)

2015-4-12 01:05

王小明 第二次花費變成負數 ...

sabery

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

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

sabery

回復  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

回復  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

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

1. For Each arng In Range("D6:D" & Cells(Rows.Count, "D").End(xlUp).Row)
   
2.     If arng < 0 Then
   
3.         With Range(Cells(arng.Row, 1), Cells(arng.Row, Columns.Count).End(xlToLeft).Address).Interior
   
4.             .Color = vbRed
   
5.         End With
   
6.     Else
   
7.         With Range(Cells(arng.Row, 1), Cells(arng.Row, Columns.Count).End(xlToLeft).Address).Interior
   
8.             .Color = vbWhite
   
9.         End With
   
10. 
    
11.     End If
    
12. Next

複製代碼

sabery

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

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

下載 (25.66 KB)

2015-4-15 05:08

可是存款卻沒有他的資料

下載 (7.24 KB)

2015-4-15 04:53

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

1. Sub TEST()
   
2. Dim i As Integer
   
3. Dim j As Integer
   
4. Dim B As Long
   
5. Sheets("A").Select
   
6.        j = 5
   
7.     Do While Sheets("B").Range("A" & j) <> ""
   
8.            i = 6
   
9.         Do While Range("B" & i) <> ""
   
10.             If Range("B" & i) = Sheets("B").Range("A" & j) Then
    
11.                 B = Sheets("A").Range("C" & i) + B
    
12.                 Range("D" & i) = Sheets("B").Range("B" & j) - B
    
13.             ElseIf Range("B" & i) <> Sheets("B").Range("A" & j) Then
    
14.                 Range("D" & i) = "不夠"
    
15.             End If
    
16.                 i = i + 1
    
17.         Loop
    
18.                 B = 0
    
19.                 j = j + 1
    
20.     Loop
    
21. MsgBox " TEST! "
    
22. End Sub

複製代碼

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

lpk187

回復 8# sabery

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

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

複製代碼

lpk187

回復 8# sabery


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

下載 (6.29 KB)

2015-4-15 20:31

A工作表

下載 (9.13 KB)

2015-4-15 20:31