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

程序太大VBA优秀

1 个答案: