Board logo

標題: [發問] 請問這個巨集如何改進 [打印本頁]
作者: pcwh3    時間: 2012-3-2 13:05     標題: 請問這個巨集如何改進

問題如附件,請各大大幫忙一下.
[attach]9808[/attach]
作者: register313    時間: 2012-3-2 14:29

回復 1# pcwh3
  1. Sub XX()
  2. Set Rng = Union(Range("B7:Q7"), Range("B16:Q16"))
  3. For Each R In Rng
  4.   If R = "" Then
  5.      R.Offset(1, 0) = ""
  6.   Else
  7.      D = Weekday([A6] + R - 1, 2)
  8.      R.Offset(1, 0) = Switch(D = 1, "MON", D = 2, "THU", D = 3, "WED", D = 4, "THU", D = 5, "FRI", D = 6, "SAT", D = 7, "SUN")
  9.      If R.Offset(1, 0) = "MON" Then
  10.         R.Resize(9, 1).Interior.ColorIndex = 36
  11.      Else
  12.         R.Resize(9, 1).Interior.ColorIndex = xlNone
  13.      End If
  14.   End If
  15. Next
  16. End Sub
複製代碼
作者: GBKEE    時間: 2012-3-2 16:10

回復 1# pcwh3
  1. Sub Ex()
  2.     Dim Rng(4) As Range, xi As Integer, E As Range
  3.     Set Rng(0) = Sheets("ABC").Range("A6")                              '日期
  4.     Set Rng(1) = Sheets("ABC").Range("B7:P7,B16:Q16")           ' 各工作表 日期 範圍
  5.     Set Rng(2) = Sheets("XYZ").Range("B7:P7,B16:Q16")
  6.     Set Rng(3) = Sheets("123").Range("B7:P7,B15:Q15")
  7.     For xi = 1 To 3
  8.         For Each E In Rng(xi)                                           '處理每一日期範圍
  9.             If Month(Rng(0) + E.Value - 1) = Month(Rng(0)) Then     '檢查 月份
  10.                 E.Offset(1) = UCase(Format(Rng(0) + E - 1, "ddd"))       '參數 "ddd" 傳回 星期字母縮寫
  11.                 E.Resize(IIf(xi = 3, 8, 9)).Interior.ColorIndex = IIf(E.Offset(1) = "MON", 36, xlNone)
  12.             Else                                                                                             
  13.                 E.Offset(1).Resize(IIf(xi = 3, 8, 9)) = ""
  14.                 E.Resize(IIf(xi = 3, 8, 9)).Interior.ColorIndex = xlNone
  15.             End If
  16.        Next
  17.     Next
  18. End Sub
複製代碼
作者: pcwh3    時間: 2012-3-2 16:56

回復 2# register313
多謝幫忙.
要努力學一下UNION及RESIZE的功能.
作者: register313    時間: 2012-3-2 17:01

回復 4# pcwh3

我只有處理第一與第二工作表
GBKEE版大的作法才能處理三個工作表
作者: pcwh3    時間: 2012-3-2 17:02

回復 3# GBKEE
多謝指導.又多學一點了.
我用了2樓大大的程式, 進行改進, 再用GOSUB功能完成直接將各工作表資料一次性更新.
作者: pcwh3    時間: 2012-3-2 17:06

回復 5# register313
多謝各位. 兩組程式我都會按我的實際情況使用，再去比較.
現時我是先用您的程序, 再自行加上GOSUB功能去一次性完成全部工作表.
作者: Hsieh    時間: 2012-3-2 18:58

回復 7# pcwh3
  1. Sub WHREPORT()
  2. Dim Rng As Range, A As Range, i%, k%
  3. With ActiveSheet
  4. st = .[A6]
  5. d = Day(DateAdd("M", 1, st) - 1)
  6. Set Rng = .Range("A6", .[A65536].End(xlUp)).SpecialCells(xlCellTypeBlanks)
  7. Rng.Areas(2)(1).Offset(, 1).Resize(2, 16) = ""
  8. Rng.Areas(1)(1).Offset(, 1).Resize(, 15).FormulaArray = "=COLUMN(A1:O1)"
  9. Rng.Areas(1)(1).Offset(1, 1).Resize(, 15).FormulaR1C1 = "=UPPER(TEXT(TEXT(R6C1,""yyyy/mm/"")&R[-1]C,""ddd""))"
  10. Rng.Areas(1)(1).Offset(, 1).Resize(2, 15) = Rng.Areas(1)(1).Offset(, 1).Resize(2, 15).Value
  11. Rng.Areas(2)(1).Offset(1, 1).Resize(, d - 15).FormulaR1C1 = "=UPPER(TEXT(TEXT(R6C1,""yyyy/mm/"")&R[-1]C,""ddd""))"
  12. Rng.Areas(2)(1).Offset(, 1).Resize(, d - 15).FormulaArray = "=TRANSPOSE(ROW(A16:A" & d & "))"
  13. Rng.Areas(2)(1).Offset(, 1).Resize(2, d - 15) = Rng.Areas(2)(1).Offset(, 1).Resize(2, d - 15).Value
  14. k = Rng.Areas(2).Row - Rng.Areas(1).Row
  15. For i = 1 To 2
  16. For Each A In Rng.Areas(i)(1).Offset(1, 1).Resize(, 15)
  17.    If A = "MON" Then
  18.    A.Offset(-1, 0).Resize(k, 1).Interior.ColorIndex = 6
  19.    Else
  20.    A.Offset(-1, 0).Resize(k, 1).Interior.ColorIndex = -4142
  21.    End If
  22. Next
  23. Next
  24. End With
  25. End Sub
複製代碼
作者: pcwh3    時間: 2012-3-3 11:40

回復 8# Hsieh
多謝hsieh兄. 三個版本相比較, hsieh兄的程式稍為難明一點, 要時間去學習理解.
但足以證明, 條條大路通羅馬.



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