Board logo

標題: [發問] 請教如何用VBA在另一工作表計算出結果？ [打印本頁]
作者: ji12345678    時間: 2013-10-3 01:36     標題: 請教如何用VBA在另一工作表計算出結果？

請教：
總表內為統計各班的生產量，
增減量工作表，為每個月的生產量增減值。
目前是以EXCEL函數處理。
因資料量龐大，請教一下大大，如何運用VBA，在另一個工作表產生增減量表，並產生每個格內的顏色格式設定。

工1班到工9班：增減量如果較上個月"增加"顏色為紅色，
                            增減量如果較上個月"減少"顏色為綠色。
工10班到工15班：增減量如果較上個月"增加"顏色為藍色，
                               增減量如果較上個月"減少"顏色為橘色。

[attach]16229[/attach]




[attach]16230[/attach]
作者: kimbal    時間: 2013-10-3 23:29

本帖最後由 kimbal 於 2013-10-3 23:34 編輯

回復 1# ji12345678
  1. Sub TEST()

  3.     Dim color As Long
  4.     Application.Calculation = xlCalculationManual
  5.     Application.ScreenUpdating = False
  6.    
  7.     Sheets("總表").Copy after:=Sheets(1)
  8.     With ActiveSheet.Range("B3")
  9.         Range(.Address, .End(xlToRight).End(xlDown)).ClearFormats
  10.         Range(.Address, .End(xlToRight).Offset(0, -1).End(xlDown)).Select
  11.         Selection.Copy
  12.         .Offset(0, 1).PasteSpecial operation:=xlPasteSpecialOperationSubtract
  13.         
  14.    
  15.         For Each Rng In Range(.Offset(0, 1), .End(xlToRight).End(xlDown))
  16.             color = 0
  17.             If Rng.Row >= 12 And Rng.Row <= 17 Then
  18.                 If Rng.Value > 0 Then
  19.                     color = 15773696
  20.                 ElseIf Rng.Value < 0 Then
  21.                     color = 52479
  22.                 End If
  23.             Else
  24.                 If Rng.Value > 0 Then
  25.                     color = 255
  26.                 ElseIf Rng.Value < 0 Then
  27.                     color = 5296274
  28.                 End If
  29.             End If
  30.             If color > 0 Then
  31.                 With Rng.Interior
  32.                     .Pattern = xlSolid
  33.                     .PatternColorIndex = xlAutomatic
  34.                     .color = color
  35.                 End With
  36.             End If
  37.         Next
  38.         Range(.Address, .End(xlDown)).Clear
  39.     End With
  40.     Application.ScreenUpdating = True
  41.     Application.Calculation = xlCalculationAutomatic

  43. End Sub
複製代碼
作者: luhpro    時間: 2013-10-4 00:04

回復 1# ji12345678
  1. Private Sub cbCal_Click()
  2.   Dim iSCol%, iTCol%, iNum%
  3.   Dim lSRow&, lTRow&
  4.   Dim sStr$
  5.   Dim shSou As Sheet1, shTar As Sheet3

  7.   Set shSou = Sheets("總表")
  8.   Set shTar = Sheets("變動")
  9.   
  10.   With shTar.Cells
  11.     .ClearContents
  12.     .Interior.ColorIndex = -4142
  13.   End With
  14.   
  15.   With shSou
  16.     iSCol = 2 ' 日期與增減量
  17.     Do While .Cells(1, iSCol) <> ""
  18.       shTar.Cells(1, iSCol) = .Cells(1, iSCol)
  19.       shTar.Cells(2, iSCol) = "增減量"
  20.       iSCol = iSCol + 1
  21.     Loop
  22.     sStr = Cells(1, iSCol - 1).Address
  23.     sStr = Mid(sStr, 2, InStr(2, sStr, "$") - 2)
  24.     shTar.Columns("B:" & sStr).ColumnWidth = 8.38
  25.    
  26.     lSRow = 3 ' 工班名
  27.     Do While .Cells(lSRow, 1) <> ""
  28.       shTar.Cells(lSRow, 1) = .Cells(lSRow, 1)
  29.       lSRow = lSRow + 1
  30.     Loop
  31.    
  32.     iSCol = 3
  33.     Do While .Cells(1, iSCol) <> ""
  34.       lSRow = 3
  35.       Do While .Cells(lSRow, 1) <> ""
  36.         sStr = .Cells(lSRow, 1)
  37.         
  38.         If Left(sStr, 1) <> "總" Then iNum = CInt(Mid(sStr, 2, Len(sStr) - 2)) Else iNum = 1
  39.         
  40.         With .Cells(lSRow, iSCol)
  41.          shTar.Cells(lSRow, iSCol) = .Value - .Offset(, -1)
  42.         End With
  43.         
  44.         With shTar.Cells(lSRow, iSCol)
  45.           Select Case .Value
  46.             Case Is > 0
  47.               If iNum > 9 Then .Interior.ColorIndex = 41 Else .Interior.ColorIndex = 38
  48.             Case 0
  49.               .Interior.ColorIndex = -4142
  50.             Case Is < 0
  51.               If iNum > 9 Then .Interior.ColorIndex = 46 Else .Interior.ColorIndex = 35
  52.           End Select ' 藍 41 橘 46 綠 35 粉 38
  53.         End With
  54.         lSRow = lSRow + 1
  55.       Loop
  56.       iSCol = iSCol + 1
  57.     Loop
  58.   End With
  59. End Sub
複製代碼
[attach]16233[/attach]
作者: ji12345678    時間: 2013-10-5 01:16

麻辣論譠真是高手如雲！
感謝各位大大教導！另外請教一下。。。。。。。
有否什麼指令或方法是 一個區城內的全部儲存格，大於零就設紅色 ，小於零就設綠色。
來取代一個一個跑儲存格？
萬分感恩，謝謝~~~~！
作者: ji12345678    時間: 2013-10-5 01:45

真不好意思，
是否能使用VBA先設好 一格  "設定格式化的條件(Ｄ)"
再只將它的格式複製到其他的大量儲存格？

萬分感謝指教，謝謝~~~~！



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