程序過大VBA excel

Question

我需要一些幫助來縮短這段代碼。

我需要使用此代碼If (linha >= 20 And linha <= 21) 50線（linha）間隔

Private Sub Worksheet_SelectionChange(ByVal Target As Range) 
    Dim foto As Range 
    Dim destino As Range 
    Dim linha As Long 
    Dim fName As String 
    Dim pName As String 
    Dim iName As String 
    Dim iNameClean As String 
    Dim iNameExcel As String 
    Dim fNameExcel As String 

    Set foto = Target.Cells(1) 
    Set destino = Me.Range("AU:BC,BN:BV,CG:CO,CZ:DH,DS:EA,EL:ET,FE:FM,FX:GF,GQ:GY,HJ:HR,IC:IK,IV:JD,JO:JW,KH:KP,NF:NN,NY:OG,OR:OZ,PK:PS") 
    If Not Application.Intersect(foto, destino) Is Nothing Then 
     linha = foto.Row 


    If (linha >= 20 And linha <= 21) Then 
     With ActiveSheet 
    fName = Application.GetOpenFilename("Picture files (*.jpg;*.gif;*.bmp;*.tif), *.jpgs;*.gif;*.bmp;*.tif", , _ 
"Select picture to insert") 
      iName = Dir("" & fName & "") 
      If fName = "False" Then Exit Sub 
      iNameClean = Left(iName, Len(iName) - 4) 
      iNameExcel = "+Info" 
      fNameExcel = "F:\path\EXCEL\" & foto.Offset(1, 3).Value & ".xlsx" 
      With ActiveSheet 
      .Unprotect Password:="1234" 
       ActiveSheet.Pictures.Insert(fName).Select 
       foto.Offset(0, 2).Formula = "=HYPERLINK(""" & fName & """,""" & iNameClean & """)" 
       foto.Offset(0, 2).Font.ColorIndex = 1 ' preto 
       foto.Offset(0, 2).Font.Size = 9 
       foto.Offset(0, 2).Font.Underline = False 
       foto.Offset(0, 3).Formula = "=HYPERLINK(""" & fNameExcel & """,""" & iNameExcel & """)" 
       foto.Offset(0, 3).Font.ColorIndex = 1 ' preto 
       foto.Offset(0, 3).Font.Size = 9 
       foto.Offset(0, 3).Font.Underline = False 
       With Selection.ShapeRange 
        .LockAspectRatio = msoFalse 
        .Height = ActiveCell.MergeArea.Height 
        .Width = ActiveCell.MergeArea.Width 
        .Top = ActiveCell.Top 
        .Left = ActiveCell.Left 
       End With 
      .Protect Password:="1234" 
      End With 
     End With 
    End If 

End Sub 

Answer 1

首先，不要放在一個事件處理全功能的程序。只需要將事件路由到適當程序所需的最小代碼。這可以讓您的事件處理程序更簡潔，更易於維護。大部分工作將在額外的程序中進行。

我將定義一個新程序DoStuff，它將處理linha s，並且我們發送到DoStuff的參數可以在Case開關內進行控制。

這樣，DoStuff過程體並不需要被複制50次以上，你可以簡單地添加到Case聲明中Worksheet_Change事件處理程序，並進行更改（如果需要）的可選參數。

Private Sub Worksheet_SelectionChange(ByVal Target As Range) 
    Dim foto as Range 
    Dim destino as Range 
    Dim linha As Long 

    Set foto = Target.Cells(1) 
    Set destino = Me.Range("AU:BC,BN:BV,CG:CO,CZ:DH,DS:EA,EL:ET,FE:FM,FX:GF,GQ:GY,HJ:HR,IC:IK,IV:JD,JO:JW,KH:KP,NF:NN,NY:OG,OR:OZ,PK:PS") 
    If Not Application.Intersect(foto, destino) Is Nothing Then 
     linha = foto.Row 
    End If 

    Select Case linha 
     Case 20, 21 
      Call DoStuff(foto, 1, 9, "1234") 

     '### Simply add additional "Case" statements for each linha pair 
     ' NOTE: You can send different parameters to the DoStuff procedure! 
     Case 22, 23 
      Call DoStuff(foto, 1, 9, "ABCD", "G:\another path\Excel\", ".xlsb") 


     'Etc... 

    End Select 

End Sub 

這裏是DoStuff程序。對於password，filepath，fileExt（在With塊中使用），此過程取foto範圍（技術上爲任何範圍對象）和可選參數（具有默認值）。

Sub DoStuff(foto as Range, _ 
      Optional fontColor as Long=1, 
      Optional fontSize as Long=9, _ 
      Optional password as String="1234", _ 
      Optional filePath as String="F:\path\EXCEL\", _ 
      Optional fileExt as String=".xlsx") 

    Dim fname as String 
    Dim pName As String 
    Dim iName As String 
    Dim iNameClean As String 
    Dim iNameExcel As String 
    Dim fNameExcel As String 

    If Right(filePath,1) <> "\" Then filePath = filePath & "\" 

    fName = Application.GetOpenFilename("Picture files (*.jpg;*.gif;*.bmp;*.tif), *.jpgs;*.gif;*.bmp;*.tif", , _ 
    "Select picture to insert") 
    iName = Dir("" & fName & "") 
    If fName = "False" Then Exit Sub 
    iNameClean = Left(iName, Len(iName) - 4) 
    iNameExcel = "+Info" 
    fNameExcel = filePath & foto.Offset(1, 3).Value & fileExt 

    With foto.Parent 'Worksheet 
     .Unprotect Password:=password 
     .Pictures.Insert(fName).Select 
     With foto.Offset(0,2) 
      .Formula = "=HYPERLINK(""" & fName & """,""" & iNameClean & """)" 
      .Font.ColorIndex = fontColor ' preto 
      .Font.Size = fontSize 
      .Font.Underline = False 
     End With 
     With foto.Offset(0, 3) 
      .Formula = "=HYPERLINK(""" & fNameExcel & """,""" & iNameExcel & """)" 
      .Font.ColorIndex = fontColor ' preto 
      .Font.Size = fontSize 
      .Font.Underline = False 
     End With 
     With Selection.ShapeRange 
      .LockAspectRatio = msoFalse 
      .Height = foto.MergeArea.Height 
      .Width = foto.MergeArea.Width 
      .Top = foto.Top 
      .Left = foto.Left 
     End With 
    .Protect Password:=password 
    End With 

End Sub