有关数据验证和图问题

cmo9020

test.rar (166.95 KB, 下载次数: 7)

2023-1-14 20:38 上传

点击文件名下载附件

请问导师们有关数据验证和图问题

功能是这样,b4单元格输入号码
执行代码会搜寻和b4相同名称工作簿名称
范本工作表a15:N200会先做清空
在把目标工作簿a15:N200复制到范本工作表
遇到一个小问题...
反黄色部份的单元格有做数据验证,
数据验证一旦下拉选择做改变....
执行就会产生代码错误,请问我要怎么去修改代码

cmo9020

目前我想到的办法是加入On Error Resume Next....
不知道导师们还有什么好方法

Sub T()
Dim WorkbookToOpen As Workbook
Dim fileName As String, filePath As String
Dim fso As Object, folder As Object

fileName = ThisWorkbook.Worksheets("范本").Range("B4").Value
filePath = "C:\Users\User\Desktop\TEST"
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(filePath)

ThisWorkbook.Worksheets("范本").Range("A15:N200").Clear

Dim img As Object
For Each img In ThisWorkbook.Worksheets("范本").Shapes
    If Not img Is Nothing And Not img.TopLeftCell Is Nothing Then
        If img.TopLeftCell.Row >= 15 And img.TopLeftCell.Row <= 200 And _
        img.TopLeftCell.Column >= 1 And img.TopLeftCell.Column <= 14 Then
            img.Delete
        End If
    End If
Next

If SearchFolder(folder, fileName) <> "" Then
    Set WorkbookToOpen = Workbooks.Open(SearchFolder(folder, fileName))
    WorkbookToOpen.Worksheets(1).Range("A15:N200").Copy _
    Destination:=ThisWorkbook.Worksheets("范本").Range("A15:N200")
    WorkbookToOpen.Close
Else
    MsgBox "NO " & fileName & " DATA。"
End If
End Sub

Function SearchFolder(ByVal folder As Object, ByVal fileName As String) As String
Dim subfolder As Object, subsubfolder As Object
Dim file As Object

For Each file In folder.Files
    If file.Name = fileName & ".xlsx" Then
        SearchFolder = file.path
        Exit Function
    End If
Next file

For Each subfolder In folder.subfolders
    Dim path As String
    path = SearchFolder(subfolder, fileName)
    If path <> "" Then
        SearchFolder = path
        Exit Function
    End If

    For Each subsubfolder In subfolder.subfolders
        path = SearchFolder(subsubfolder, fileName)
        If path <> "" Then
            SearchFolder = path
            Exit Function
        End If
    Next subsubfolder
Next subfolder
End Function