合并两个代码

Question

亲爱的，现在在您的帮助下，我有两个代码在单独的工作表中测试时完美运行，但是当我将它们放在同一张工作表中时，没有任何效果，因为我不知道如何将它们组合在一起是一个代码，当打开一个新模块来添加第二个代码标题不会更改为工作表更改 - 如果可能的话，我需要您的帮助将它们组合在一个代码中，请告诉我如何解决这个问题...我的两个代码在上面编辑的问题中 - 比您的尝试帮助我 这是我的代码

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, Range("E5:G5")) Is Nothing Then
      
     
Range("D11").Value = Format(ThisWorkbook.BuiltinDocumentProperties("Last Save time"), "short date")

    
End If
    
End Sub

*****2ND CODE*****
Sub Worksheet_Change(ByVal Target As Range)
    Dim ws As Worksheet, pic As Shape, a As Variant, r As Long, path As String
    Set ws = ThisWorkbook.ActiveSheet
    path = "D:\Desktop\Guards\Guards National IDs\"
    'The array below contains picture shape names, condition ranges (numbers in which correlate to picture file names), and add-to ranges
    a = [{"picture1","E5","D44"; "picture2","G5","J44"}] 'Create a 2x3/multidimensional array using the Application.Evaluate [] shortcut.

    For r = LBound(a) To UBound(a)
        If Target.Address(0, 0) = a(r, 2) Then 'consider using If Not Intersect(Target, Range("E5,G5") or Range("E5:G5")) Is Nothing Then...with other changes in the code if you want to change multiple conditions in one swoop
            Debug.Print "Potential edit in sheet: " & ws.Name & " cell: " & Target.Address(0, 0)
            If Target.Value <> "" Then 'delete old pic insert new one
                Debug.Print " (Del old if exists, Add the new: " & a(r, 1) & " into cell: " & a(r, 3) & ")"
                On Error GoTo AddShapeHandler
                Debug.Print " (" & ws.Shapes(a(r, 1)).Name & " exists, deleting)" 'checking if pic exists
                ws.Shapes(a(r, 1)).Delete
AddShapeHandler:
                Debug.Print " (Adding the new " & a(r, 1) & ")"
                path = picPath(path, ws.Range(a(r, 2)).Value)
                If Len(path) < 2 Then Exit Sub 'either the path is invalid or the picture file which name contains ws.Range(a(r, 1)).Value wasn't found
                Set pic = ws.Shapes.AddPicture(path, False, True, ws.Range(a(r, 3)).Left, ws.Range(a(r, 3)).Top, 182, 95)
                pic.Name = a(r, 1)
                Exit For
            Else
                Debug.Print " (Del old if exists: " & a(r, 1) & " and optionally clear cell: " & a(r, 3) & ")"
                On Error GoTo DelShapeHandler
                Debug.Print " (" & ws.Shapes(a(r, 1)).Name & " exists, deleting)" 'checking if pic exists
                ws.Shapes(a(r, 1)).Delete
DelShapeHandler:
'                ws.Range(a(r, 3)).ClearContents 'comment-out if you want keep the existing contents in cells D44, J44
                Exit For
            End If
        End If
    Next
End Sub

Function picPath(path As String, picName As Variant) As String
    Dim fso, file, files, folder As Object
    Set fso = CreateObject("Scripting.FileSystemObject") 'consider using dir() instead of fso
    Debug.Print "  [searching for a picture which name contains: " & picName & " in path: " & path & "]"
    If fso.FolderExists(path) Then 'Path is valid/folder exists
        Set folder = fso.GetFolder(path)
        Set files = folder.files
        If files.Count = 0 Then 'Folder is empty
            Debug.Print "  [(exiting sub): 0 files in " & path & "]"
            picPath = 0: Exit Function 'return 0
        End If
        For Each file In files
            Debug.Print "   [(found the following file: " & file.Name & " in " & path & ")]"
            If InStr(file.Name, picName) Then 'InStr(look_inside, look_for)
                Debug.Print "  [(success): found a picture which name contains: " & picName & " in " & path & "]"
                picPath = file.path: Exit Function 'return picture's path
            End If
        Next
    Else
        Debug.Print "  [(exiting sub): didn't find a picture which name contains: " & picName & " in " & path & "]"
        picPath = 0: Exit Function 'return 0
    End If
End Function

Answer 1

右键单击要运行代码的工作表的选项卡，然后选择 查看代码

在打开的代码屏幕上输入此代码：

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Range("D22:J22"), Target) Is Nothing Then
        Range("D11").Value = Format(ThisWorkbook.BuiltinDocumentProperties("Last Save time"), "short date")
    End If
End Sub 

注意： 如果您在工作表中已经有

Worksheet_Change

代码，则需要将其合并到其中 - 您不能有两个同名的过程。

NB2： 仅当您手动更新单元格时才会触发此代码，而不是因为它们包含公式而更新。

要与您现有的代码结合，只需将我的答案中的代码正文（即

Worksheet_Change

和

End Sub

行之间的代码）粘贴到代码中

Worksheet_Change

行的正下方。

Sub Worksheet_Change(ByVal Target As Range) 
    'My code  
    If Not Intersect(Range("D22:J22"), Target) Is Nothing Then
        Range("D11").Value = Format(ThisWorkbook.BuiltinDocumentProperties("Last Save time"), "short date")
    End If  
    'The rest of your code.
    Dim ws As Worksheet, pic As Shape, a As Variant, r As Long, path As String
    Set ws = ThisWorkbook.ActiveSheet  
    .
    .
    .