プロシージャが大きすぎるVBA Excel

Question

このコードを短くするにはいくつかの助けが必要です。私は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

まず、このコードIf (linha >= 20 And linha <= 21)を使用する必要が

は、イベントハンドラで全体の機能手順を入れないでください。イベントを適切な手順にルーティングするために必要な最小限のコードのみを入れてください。これにより、イベントハンドラが簡潔になり、保守が容易になります。追加の手順で作業の大半が行われます。

私はlinha秒を処理する新しい手順DoStuffを定義します、と私たちはDoStuffに送信パラメータがCaseスイッチ内で制御することができます。 DoStuffプロシージャ本体が50倍以上をコピーする必要はありません（必要な場合）

この方法で、あなたは単にオプションのパラメータにWorksheet_ChangeイベントハンドラでCaseステートメントに追加、および変更を行うことができます。

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