程序太大的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 来处理linhas，我们发送给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 过程。此过程采用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