Arr1 = .Range("A2").Resize(.Cells(.Rows.Count, 1).End(xlUp).Row - 1, 4).Value '将所有数据写入数组
For i = 1 To UBound(Arr1, 1) '遍历数据
'取商品名称与价格
If Dic1.Exists(Arr1(i, 1) & Arr1(i, 2)) = False Then'如果字典中没有key则
j = j + 1
ReDim Preserve Arr2(1 To 2, 1 To j)'数组增加一列，最终数据增加一行
Arr2(1, j) = Arr1(i, 1): Arr2(2, j) = Arr1(i, 2)
End If
Dic1.Item(Arr1(i, 1) & Arr1(i, 2)) = Dic1.Item(Arr1(i, 1) & Arr1(i, 2)) + Arr1(i, 3) '取数量
Dic2.Item(Arr1(i, 1) & Arr1(i, 2)) = Dic2.Item(Arr1(i, 1) & Arr1(i, 2)) + Arr1(i, 4) '取金额
Next
With .Range("G2")
.Resize(UBound(Arr2, 2), 2) = Application.WorksheetFunction.Transpose(Arr2) '写入商品名称与单价
.Offset(0, 2).Resize(Dic1.Count, 1) = Application.WorksheetFunction.Transpose(Dic1.items) '写入数量
.Offset(0, 3).Resize(Dic2.Count, 1) = Application.WorksheetFunction.Transpose(Dic2.items) '写入金额
End With
3、非常用案例
使用期限设置
思路：打开工作簿时给"期限"和当前日期赋值，并提醒报表使用者，关闭工作簿时（Kill .FullName）删除。注意：删除后数据无法恢复。
Private a$, 期限$ '定义共用变脸
Sub Auto_open() '打开工作簿时执行
期限 = "2018年2月27日"
a = Format(Date, "yyyy年m月d日") '当前年月日
If a >期限 Then MsgBox "超过使用期限；" &Chr(13) _
& "工作簿将自动删除；" &Chr(13) _
& "请复制要保存的数据"
End Sub
'Sub Auto_close() '打开工作簿时执行
If a >期限 Then
With ThisWorkbook '引用ThisWorkbook
.Saved = True '标识为已保存状态
.ChangeFileAccess Mode:=xlReadOnly '设为只读模式
Kill .FullName '删除ThisWorkbook
.Close '关闭ThisWorkbook
End With
End If
End Sub
建立超链接工作表目录Hyperlinks
Sub 建立工作表目录()
Dim Sht As Worksheet, i As Integer '声明一个对象变量一个Integer变量
For Each Sht In Sheets '遍历所有表
'如果sht的名字等于"工作表目录"，那么跳转至标签Mulu处
If Sht.Name = "工作表目录" Then GoToMulu
Next
Worksheets.Add Worksheets(1) '新建一个工作表，将它放在第一个工作之前
ActiveSheet.Name = "工作表目录" '将活动工作表命名为"工作表目录"
Mulu: '设置一个名为"Mulu"的标签
Worksheets("工作表目录").Range("A:B").Clear '清除A、B两列的值
For Each Sht In Worksheets '遍历所有工作表
If Sht.Name<> "工作表目录" Then '如果sht的名称不等于"工作表目录"
i = i + 1 '累加计数器
Worksheets("工作表目录").Cells(i, 1).Value = i '在A列输入编号
'在B列创建超级链接,从而允许单击单元格时进入相应的工作表
Worksheets("工作表目录").Hyperlinks.Add Anchor:=Worksheets("工作表目录").Cells(i, 2), Address:="", SubAddress:="'" &Sht.Name& "'!A1", TextToDisplay:=Sht.Name, ScreenTip:="单击打开：" &Sht.Name
End If
Next
End Sub
Rem Hyperlinks.Add方法用于创建超级链接，其语法如下：
Rem Hyperlinks.Add(Anchor, Address, SubAddress, ScreenTip, TextToDisplay)
Rem 各参数的含义如下:
Rem 名称必选/可选数据类型说明
Rem Anchor 必选 Object 超链接的位置。可为 Range 或 Shape 对象。
Rem Address 必选 String 超链接的地址。
Rem SubAddress可选 Variant 超链接的子地址。
Rem ScreenTip 可选 Variant 当鼠标指针停留在超链接上时所显示的屏幕提示。
Rem TextToDisplay可选 Variant 要显示的超链接的文本。
Inputbox用法
注意：inputbox只能调用本工作簿中的区域，需增加其他语句配合调用其他工作簿。
粘贴时跳过隐藏行
思路：用inputbox选择区域，然后Rng选取可见区域，循环可见区域单元格，逐一赋值
Sub 粘贴时跳过隐藏行()
On Error Resume Next '当程序出错时继续执行下一句
Dim Rng As Range, i%, C As Range, 复制 As Range, 粘贴 As Range, Arr()
Set 复制 = Application.InputBox(prompt:="请选择要复制的区域", Type:=8)
If 复制 Is Nothing Then Exit Sub '如果没有赋值，退出程序
Set 粘贴 = Application.InputBox(prompt:="请选择要粘贴的区域", Type:=8)
If 粘贴 Is Nothing Then Exit Sub '如果没有赋值，退出程序
Set Rng = 粘贴.SpecialCells(xlCellTypeVisible) '将选择区域可见的部分赋值给rng
Arr = 复制.Value '将复制的数据赋值给数组
For Each C In Rng '逐一选取可见的单元格
i = i + 1
C.Value = Arr(i, 1) '将复制的内容逐一粘贴到目标区域
If i = UBound(Arr, 1) Then Exit For '如果复制的值结束，退出循环。（本句避免复制的区域低于粘贴区域时出错）
Next
End Sub
閱讀更多 Excel風采 的文章
