程序过大VBA excel
我需要一些帮助来缩短这段代码。
我需要使用这个代码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
首先，不要将整个function过程放在事件处理程序中。 只需要将事件路由到适当的过程所需的最小代码。 这使您的事件处理程序更简洁，更易于维护。 大部分工作将在额外的程序中进行。
我将定义一个新的DoStuff程序，它将处理linha ，我们发送给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