Процедура слишком велика 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 с, а также параметры, которые мы посылаем к 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. Эта процедура принимает диапазон foto (или любой объект диапазона, технически) и необязательные параметры (со значениями по умолчанию) для password, filepath, fileExt (которые используются в блоке With).

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