acdx

回復 2# GBKEE
我也有一段巨集該如簡化?
Private Sub format()

Dim ws As Worksheet
Dim sName As String

sName = "PTAVS"
On Error Resume Next
Set ws = Sheets(sName)

If ws Is Nothing Then
    Worksheets.Add after:=Worksheets(Worksheets.Count)
    Worksheets(Worksheets.Count).Name = sName
    ws.Activate
Else
    MsgBox sName & "工作表已存在。"
    Sheets("Result").Select
    Exit Sub
End If

Cells.Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection.Font
        .Name = "Arial"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With

Range("B1:M1").Merge
    Range("A1:A4").Select
    With Selection
        .WrapText = False
        .MergeCells = True
        .Value = "C1~C5"
    End With
   
    Range("B2:G2").Select
    With Selection
        .WrapText = False
        .MergeCells = True
        .Value = "(sone)"
    End With
   
    Range("B3:D3").Select
    With Selection
        .WrapText = False
        .MergeCells = True
        .Value = "H"
    End With
   
    Range("E3:G3").Select
    With Selection
        .WrapText = False
        .MergeCells = True
        .Value = "M"
    End With
   
    Range("B4:G4").Select
    With Selection
        .WrapText = True
        .MergeCells = False
    End With
    Range("B4").Value = "mean"
    Range("C4").Value = "standard deviation"
    Range("D4").Value = "mean+CV*stdev"
   
    Range("B4:D4").Copy
    Range("E4").Select
    ActiveSheet.Paste
   
    Range("B2:G4").Copy
    Range("H2").Select
    ActiveSheet.Paste
   
    Range("H2").Value = "(tu)"
   
    Range("A1:M4").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Font
        .Name = "Arial"
        .Size = 10
    End With
Sheets("Result").Select
End Sub
'-------------------------------------
這段code有很大的部分是在做儲存格的合併以及畫框線 這該如何簡化呢?

GBKEE

回復 11# acdx

1. Option Explicit
   
2. Private Sub format()
   
3.     Dim ws As Worksheet, sName As String, AR(1 To 2), I As Integer
   
4.     sName = "PTAVS"
   
5.     On Error Resume Next
   
6.     Set ws = Sheets(sName)
   
7.     If ws Is Nothing Then
   
8.         Worksheets.Add after:=Worksheets(Worksheets.Count)
   
9.         Worksheets(Worksheets.Count).Name = sName
   
10.         Set ws = Sheets(sName)
    
11.     Else
    
12.         MsgBox sName & "工作表已存在。"
    
13.         Sheets("Result").Select
    
14.         Exit Sub
    
15.     End If
    
16.     With ws.Cells
    
17.         .HorizontalAlignment = xlCenter
    
18.         .VerticalAlignment = xlCenter
    
19.         .Orientation = 0
    
20.         .AddIndent = False
    
21.         .IndentLevel = 0
    
22.         .ShrinkToFit = False
    
23.         .ReadingOrder = xlContext
    
24.         .MergeCells = False
    
25.         With .Font
    
26.             .Name = "Arial"
    
27.             .Size = 10
    
28.             .Strikethrough = False
    
29.             .Superscript = False
    
30.             .Subscript = False
    
31.             .OutlineFont = False
    
32.             .Shadow = False
    
33.             .Underline = xlUnderlineStyleNone
    
34.             .ColorIndex = xlAutomatic
    
35.             .TintAndShade = 0
    
36.             '.ThemeFont = xlThemeFontNone  '2003沒這參數
    
37.         End With
    
38.         .Range("B1:M1").Merge
    
39.         AR(1) = Array("A1:A4", "B2:G2", "B3:D3", "E3:G3", "B4:G4")
    
40.         AR(2) = Array("C1~C5", "(sone)", "H", "M", "")
    
41.         For I = 0 To UBound(AR(1))
    
42.             With .Range(AR(1)(I))
    
43.                 .WrapText = False
    
44.                 .MergeCells = IIf(I < UBound(AR(1)), True, False)
    
45.                 .Value = AR(2)(I)
    
46.             End With
    
47.         Next
    
48.         .Range("B4:D4").Value = Array("mean", "standard deviation", "mean+CV*stdev")
    
49.         .Range("B4:D4").Copy .Range("E4")
    
50.         .Range("B2:G4").Copy .Range("H2")
    
51.         .Range("H2").Value = "(tu)"
    
52.         With .Range("A1:M4")
    
53.             For I = 5 To 12   '畫框線
    
54.                 With .Borders(I)
    
55.                     .LineStyle = IIf(I >= 7, xlContinuous, xlNone)
    
56.                     If I >= 7 Then .ColorIndex = 0
    
57.                     'If I >= 7 Then .TintAndShade = 0       '2003框線沒這屬性
    
58.                     If I >= 7 Then .Weight = xlThin
    
59.                 End With
    
60.             Next
    
61.             .Font.Name = "Arial"
    
62.             .Font.Size = 10
    
63.         End With
    
64.     End With
    
65.     Sheets("Result").Select
    
66. End Sub

複製代碼

acdx

回復 12# GBKEE
每次來這邊求救總是能從版上各位前輩的解答中獲得我未想過的寫法，讓我也從中學到不少
在這裡也想請G大介紹幾本不錯的工具書讓我能從中精進自己的功力
希望將來有一天不再只是上來這邊發問也能向板上幾位大大可以幫其他人解惑 謝謝

GBKEE

回復 13# acdx
工具書一般都是一樣的,多看多練習,日久候一定可以替後人解惑的.