Excel-双击自动引用图片(二)

发表于 更新于 分类于 ， 阅读次数：

　在Excel-双击自动引用图片(一)中,已经成功实现双击调用同Worksheet的不同sheets的区域,并转换成图片显示.接下来开始进阶的内容了:调用不同Worksheet的不定sheets区域(后台显示)、图片命名等.最主要的是将代码以过程封装起来,便于调用.

需求描述

　本次需求包括:数据来源不同Worksheet、后台调用Worksheet、图片属性操作、封装调用.

准备

　由于需要将代码封装调用，所以要了解VBA中函数定义、过程调用。

进阶知识

　VBA中有两种定义方式:Sub function.Sub是过程、Function是函数.两者区别在于Sub不能返回值、Function可以返回值；Sub可以直接执行、Function需要调用才能执行.由于需要直接执行,所以使用Sub.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub testS(arg)
	Msgbox "调用Sub,传递的参数为" & arg
	If arg = 1 Then
		Exit Sub
	End If
	Msbox "结束"
End Sub

Function testF(arg)
	Msgbox "调用Function,传递的参数为" & arg
	If arg = 1 Then
		Exit Function
	End If
	Msbox "结束"
End Function

　VBA使用CreateObject来创建对象.

编写思路

　通过对需求的解读,可以将整体分为三块:1.工作Worksheet获取双击单元格值、2.根据单元格值获取对应数据区域、3.根据对应数据区域生成图片.三块每块对应一个过程:第一块创建对象、变量等，并获取单元格值，向第二块传递需要Worksheet对象和单元格值、第二块向第三块传递[Worksheet对象、sheets值、数据区域、高度].

总结

  1. 对象在使用完之后,需要清空,要不然一直会在内存当中;
  2. 单元格包含某个值的时候,使用InStr(Range(“A1”), getValue).

完整代码

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) '定义双击事件
    Dim getExit As Integer
    getExit = 0
    Application.ScreenUpdating = False '屏幕不更新
    
    For Each im In ActiveSheet.Shapes '删除名字为测试的图片
        If im.Name = "测试" Then
            im.Delete
        End If
    Next

    Dim getValue As String '单元格值
    Dim Work1 As Workbook '定义工作Excel变量
    Dim Work2 As Workbook '定义工作Excel变量
    top = Target.top ' 获取当前活动单元格的高度

    Set Work1 = CreateObject("C:\Users\Hywell\Desktop\test.xlsx") '创建Worksheet对象
    Set Work2 = CreateObject("C:\Users\Hywell\Desktop\test2.xlsx") '创建Worksheet对象

    Allsheets = Array(Work1, Work2) '定义工作Excel数组
    
    getValue = Range(Target.Address) '获取当前活动单元格地址的内容
    If Target.Column = 6 Then '判断是否为F列
        If getValue = "" Then
            MsgBox "数据为空!"
        Else
            For Each i In Allsheets '遍历工作Excel数组
                If getExit = 0 Then
                    Call getResult(i, getValue, getExit, top) '调用getResult函数 获取所需数据区域
                Else
                    Exit For
                End If
            Next
            If getExit = 0 Then
                MsgBox "找不到对应明细表!"
            End If
        End If
    End If
    
    Set Work1 = Nothing '清空Work1对象
    Set Work2 = Nothing '清空Work2对象
    
End Sub

Sub getResult(Worksheet, getValue, getExit, top) '获取数据(getValue)区域
    Dim getInt As Integer '开始行数
    Dim getInt2 As Integer '最后行数
    Dim getNum As Integer '用于退出Fox循环
    Dim getWork As Integer '获取工作的sheet
    Dim Time As String '定义定位标识符
    
    getInt = 0 '初始化
    getInt2 = 0 '初始化
    getNum = 0 '初始化
    Time = "日期" '初始化

    For y = 1 To Worksheet.Sheets.Count '遍历工作Excel中的Sheet的数量
        For i = 1 To Worksheet.Sheets(y).UsedRange.Rows.Count '遍历sheet已经被使用单元格的行数
            If Worksheet.Sheets(y).Range("F" & i) = getValue Or InStr(Worksheet.Sheets(y).Range("I" & i), getValue) Then '根据货号取得对应sheet的I列中第一次出现
                getInt = i
                getNum = getNum + 1
                Exit For
            End If
        Next
    
        If getInt <> 0 Then
            For i = getInt To Worksheet.Sheets(y).UsedRange.Rows.Count '从getInt遍历sheet2已经被使用单元格的行数
                If InStr(Worksheet.Sheets(y).Range("A" & i), Time) Then
                    getInt2 = i + 1
                    Exit For
                End If
            Next
        End If

        If getInt <> 0 Then
            getWork = y
            Exit For
        Else
            getWork = 1
        End If
    Next

    If getInt2 = 0 Then
        getInt2 = getInt
    End If
    
    If getInt <> 0 Then
        Call getImage(Worksheet, getWork, getInt, getInt2, top) '调用getImage生成图片
        getExit = getExit + 1
    End If
    
End Sub

Sub getImage(Worksheet, getWork, getInt, getInt2, top)
    Worksheet.Sheets(getWork).Range("A" & getInt - 2 & ":O" & getInt2).Copy
    
    With ActiveSheet.Pictures.Paste(Link:=True) '设置图片属性
        .Left = 1110
        .top = top
        .Name = "测试"
    End With
    Application.CutCopyMode = False
End Sub