12
返回列表 上一主題 發帖

[發問] 請問此段巨集如何簡化或加快速度??

acdx

帖子
132 
主題
56 
精華
0 
積分
190 
點名
0  
作業系統
Win10 
軟體版本
Office 365 
閱讀權限
20 
性別
男 
註冊時間
2012-5-17 
最後登錄
2024-4-29 
11# 跳轉到 »
發表於 2013-9-6 15:35 | 只看該作者
回復 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有很大的部分是在做儲存格的合併以及畫框線 這該如何簡化呢?

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
12#
發表於 2013-9-6 17:04 | 只看該作者
回復 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

acdx

帖子
132 
主題
56 
精華
0 
積分
190 
點名
0  
作業系統
Win10 
軟體版本
Office 365 
閱讀權限
20 
性別
男 
註冊時間
2012-5-17 
最後登錄
2024-4-29 
13#
發表於 2013-9-8 15:32 | 只看該作者
回復 12# GBKEE
每次來這邊求救總是能從版上各位前輩的解答中獲得我未想過的寫法，讓我也從中學到不少
在這裡也想請G大介紹幾本不錯的工具書讓我能從中精進自己的功力
希望將來有一天不再只是上來這邊發問也能向板上幾位大大可以幫其他人解惑 謝謝

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
14#
發表於 2013-9-8 15:53 | 只看該作者
回復 13# acdx
工具書一般都是一樣的,多看多練習,日久候一定可以替後人解惑的.
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 【是否發揮了良能？】人間壽命因為短暫，才更顯得珍貴。難得來一趟人間，應問是否為人間發揮了自己的良能，而不要一味求長壽。
12
返回列表 上一主題