vba處理資料的經驗談

VBA编程是经常会用到字符串拆分函数SPLIT，用法也不复杂，但是大家对于这个函数的参数未必完全了解，下面结合示例讲解一下参数的用法。
 
SPLIT函数的语法格式如下：
 
Split(expression, [ delimiter, [ limit, [ compare ]]])
 
参数
含义
express
需要拆分的字符串
delimiter
参数为拆分的分隔符，如果省略则使用空格做为分隔符
limit
指定返回字符串的数量
compare
指定拆分子字符串时的比较类型
先来看一个示例，现在需要拆分Good good study day day up为单个单词。
 
Sub Demo1()
    Dim strString As String
    Dim varResult As Variant
    Dim arrResult() As String
    strString = "Good good study day day up"
    varResult = VBA.Split(strString)
    arrResult = VBA.Split(strString)
End Sub
 
VBA.Split(strString)省略delimiter参数，则使用空格做为分隔符，拆分为6个单词字符串，在【本地窗口】中可以查看数组的值，如下图所示。
 
 请注意变量声明语句，用于保存结果的数组，可以使用如下两种方式：Variant变量或者字符串数组，但是不可以声明为Variant数组。
 
    Dim varResult As Variant
    Dim arrResult() As String
 
一般情况下，都无须指定LIMIT参数，下面看一个使用LIMIT参数的例子。对于一些国外地址如：888, Ocean Wind Rd, Markham, V4A，需要拆分为888，Ocean Wind Rd和Markham, V4A，而不是拆分为4段，此时就需要设置LIMIT参数为3。
 
Sub Demo2()
    Dim strString As String
    Dim arrResult() As String
    Dim i As Integer
    strString = "888, Ocean Wind Rd, Markham, V4A"
    arrResult = VBA.Split(strString, ",", 3)
    For i = LBound(arrResult) To UBound(arrResult)
        Debug.Print Trim(arrResult(i))
    Next i
End Sub
 
接下来看一下如何使用compare参数，下面示例代码中设置为vbTextCompare，即执行文本比较，也就是说忽略字符大小写区别（S和s都可以作为分界符）。如下代码结果为包含4个元素的字符串数组（AAA，BBB，CCC和DDD）。
 
Sub Demo3()
    Dim strString As String
    Dim arrResult() As String
    Dim i As Integer
    strString = "AAAsBBBSCCCsDDD"
    arrResult = VBA.Split(strString, delimiter:="s", compare:=vbTextCompare)
    For i = LBound(arrResult) To UBound(arrResult)
        Debug.Print Trim(arrResult(i))
    Next i
End Sub
 
如果将compare参数设置为vbBinaryCompare，那么结果就会不同了。
 
Sub Demo4()
    Dim strString As String
    Dim arrResult() As String
    Dim i As Integer
    strString = "AAAsBBBSCCCsDDD"
    arrResult = VBA.Split(strString, delimiter:="s", compare:=vbBinaryCompare)
    For i = LBound(arrResult) To UBound(arrResult)
        Debug.Print Trim(arrResult(i))
    Next i
End Sub
 
字符串被拆分为三段，BBB和CCC之间的S不再做为分界符。
 
 
 
AAA
 BBBSCCC
 DDD
 
 
通过这个讲解，希望大家完全明白了SPLIT函数的用法。
 
 
参考文章
 《VBA JOIN函数详解》

 
文章目录
 
创建字典对象
字典的属性|方法
案例
去重
求和
计数
匹配
key的组合和分割
字典value多字段累加
字典求和和计数同时进行
类似sql的join操作
  
 

 
创建字典对象
 
'后期绑定：方便代码在其他电脑上运行，推荐。
dim dic as object
Set dic = CreateObject("scripting.dictionary")

'前期绑定：可以直接声明字典对象，有对象属性和方法的提示，但在其他没有勾选引用的电脑上无法正常运行。
'引用勾选：VBE窗体-工具-引用-勾选‘Microsoft Scripting Runtime’
dim dic as New dictionary

' 字段生成键值对 key-value
key = "姓名"
value = "身高"
dic(key) = value
 
 
字典的属性|方法
 
键：dic.keys
值：dic.items
键值对条数：dic.count
判断是否存在键key：dic.exists(key)
清空字典键值对：dic.removeall
删除键为key的键值对：dic.remove key
删除字典对象：set dic = Nothing
 
with activesheet
	'dic.count：字典计数，字典中一共有多少条记录；
	'dic.keys：字典的键，写入单元格以行写入，如需以列写入单元格，调用工作表函数transpose转置；
	.cells(1,1).resize(dic.count,1) = application.worksheetfunction.transpose(dic.keys)
	'清除工作表单元格内容
	.cells.clearcontents
	
	'dic.items：字典的值；
	.cells(1,1).resize(1,dic.count) = dic.items

	'判断某内容是否存在与字典的键中
	if dic.exists("内容") then debug.print "字符串‘内容’存在于字典的键中"
	
	'清空字典，有时候其他过程也需要使用字典，当前过程已经使用完了，但我们又不想重新创建字典对象，这时候我们可以public字典全局变量，再清空字典，供新的过程使用该字典对象。
	dic.removeall
	'清除单个字典键-值对,key是字典的某个需要删除的键
	dic.remove key
end with
 
 
案例
 
去重
 
dim dic as object
dim arr
dim st
Set dic = CreateObject("scripting.dictionary")

arr = array("可乐","雪碧","鸡翅",,"可乐","汉堡包","鸡翅")
for each st in arr
	'字典的键是不能重复的，重复导入字典只会存在一个，可以利用字典这点特性去重。
	'这里不需要字典的值，设置为空字符串或其他数值都可以。
	dic(st) = ""
next
activesheet.range("a1").resize(dic.count,1) = application.worksheetfunction.transpose(d.keys)
 
求和
 
Sub dic_sumif()
Application.ScreenUpdating = False
Dim dic As Object
Dim arr
Dim i As Byte

Set dic = CreateObject("scripting.dictionary")
With ActiveSheet
    arr = .UsedRange
    For i = 2 To UBound(arr)
    	'dic(arr(i,1))没有值是默认是0，通过下面方法对每一个水果的销量进行累加。
        dic(arr(i, 1)) = dic(arr(i, 1)) + arr(i, 2)
    Next
    '使用copy方法，将表头复制到e1，f1单元格
    .Range("a1:b1").Copy .Range("e1")
    '字典键去重纵向写入到单元格
    .Cells(2, "e").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.keys)
    For i = 2 To dic.Count + 1
    	'循环输入字典键对应的值到f列
        .Cells(i, "f").Value2 = dic(.Cells(i, "e").Value2)
    Next
End With
set dic = Nothing
Application.ScreenUpdating = True
End Sub
 
效果如下图：
 
 
计数
 
如果对上面水果种类进行计数：countifs，只需要将分类汇总的值改为数值1即可，每出现一次‘+1’
 
dic(arr(i, 1)) = dic(arr(i, 1)) + 1

'在上面代码中添加下这条，修改下表头
range("f1").value2 = "计数"
 
效果如下图：
 
 
匹配
 
这个应该是使用字典应用最多的了，需要注意的是，如果使用单元格写入到字典，单元格同时也包含格式等信息，如果只需要单元格的值，要使用单元格.value2方法，同时，字典的值也可以是数组。
数据源：
 
目标：匹配‘李白’和‘后羿’的身高和体重
代码如下：
 
Sub data_match()
Application.ScreenUpdating = False
Dim dic As Object
Dim arr
Dim i As Byte

Set dic = CreateObject("scripting.dictionary")
With ActiveSheet
    arr = .Cells(1, 1).CurrentRegion
    For i = 2 To UBound(arr)
    	'这里字典的值，用的是array数组，方便我们一下匹配多个数据，省去再创建字典对象麻烦。
        dic(arr(i, 1)) = Array(arr(i, 2), arr(i, 3))
    Next
    For i = 2 To .Cells(1, "e").End(xlDown).row
        .Cells(i, "f").Resize(1, 2) = dic(.Cells(i, "e").Value2)
    Next
End With
set dic = Nothing
Application.ScreenUpdating = True
End Sub
 
效果如下：
 我在这里加入了‘妲己’，遍历用字典去匹配了，但是字典并没有‘妲己’这个key，匹配出来是空，并没有报错，大家不用担心字典没有对应key匹配而出错这种情况，这样只会将结果输出为空。~
 如果需要匹配的姓名后面有之前填写的身高和体重信息，但是载入字典的数据源并没有这个人的信息，我们在遍历匹配时，又不想使身高和体重被替换为空，这时候可以结合dic.exisst语句，判断姓名是否存在于字典的keys中，再输出匹配结果。
 
 
 
 
字典的value可以数值，字符串，数组等对象；
 
 
 
 
Array可以通过索引获取对应的值，第一个数值的索引是0；Array(1,2,3,5)(0)返回的是1
 
 
key的组合和分割
 
解决多字段匹配问题
 
dim arr
dim i,row as long
dim d as object
dim key

set d = createobject("scripting.dictionary")
with thisworkbook
	arr = .sheets(1).usedrange
	for i = 2 to ubound(arr)
		d(join(array(arr(i,1),arr(i,2),arr(i,3)),"|")) = arr(i,4)
	next
	' 把字典键值对写入到工作表
	with .sheets("输出")
		row = 2
		for each key in d.keys
			.cells(row,4).value = d(key)
			.cells(row,1).resize(1,3) = split(key,"|")
			row = row + 1
		next
	end with
end with
 
 
 
join方法可以将数组元素按照分隔符拼接起来，返回一个字符串；
 split方法，是join的反函数，将一个字符串按照分隔符分割，返回一个数组；
 
 
 
字典value多字段累加
 
比如分别加总活跃、付费等指标
 
Sub game_type_active_pay()
Dim file_directory, f As String
Dim i, last_row As Long
Dim d As Object
Dim wb As Workbook
Dim arr
Dim active_uv, pay_uv As Long
Dim pay As Double
Application.ScreenUpdating = False    ' 关闭屏幕刷新

file_directory = ThisWorkbook.Path & "/data/"
f = Dir(file_directory & "*细分品类*")
'未找到数据源，提示，关闭应用
If f = "" Then
    MsgBox "未找到命名包含‘细分品类’文字数据源，请先下载数据源......"
    Application.ScreenUpdating = True
    End    ' 结束程序
End If

Set wb = Workbooks.Open(file_directory & f)   ' 打开工作簿
Set d = CreateObject("scripting.dictionary")     ' 创建字典对象
arr = ActiveSheet.UsedRange
'On Error Resume Next
For i = 2 To UBound(arr)
    If InStr("回流用户|留存用户|新增用户", arr(i, 4)) > 0 Then
        If arr(i, 3) = "类型1" Then arr(i, 3) = "类型2"		'将类型1合并为类型2
        If d.exists(arr(i, 1) & "|" & arr(i, 3)) Then
        	' vba没法直接对数组运算，将value拆开相加
            active_uv = d(arr(i, 1) & "|" & arr(i, 3))(0)
            pay_uv = d(arr(i, 1) & "|" & arr(i, 3))(1)
            pay = d(arr(i, 1) & "|" & arr(i, 3))(2)
           ' 字段累加
            active_uv = active_uv + arr(i, 6)    '活跃累加
            pay_uv = pay_uv + arr(i, 7)   ' 付费uv累加
            pay = pay + arr(i, 8)    ' 付费累加
            d(arr(i, 1) & "|" & arr(i, 3)) = Array(active_uv, pay_uv, pay)
        Else
        	' 如果不存在，直接生成一条记录
            d(arr(i, 1) & "|" & arr(i, 3)) = Array(arr(i, 6), arr(i, 7), arr(i, 8))
        End If
    End If
Next
'On Error GoTo 0
wb.Close False    ' 关闭工作簿，不保存
Set wb = Nothing

With ThisWorkbook.Sheets("表名")
    arr = .UsedRange
    For i = 2 To UBound(arr)
        If d.exists(arr(i, 1) & "|" & arr(i, 2)) Then
            '如果新的数据源里存在该条记录，则用新的数据源覆盖
            .Cells(i, 3).Resize(1, 3) = d(arr(i, 1) & "|" & arr(i, 2))
            .Cells(i, 6).Value2 = .Cells(i, 5).Value2 / .Cells(i, 3).Value2
            d.Remove arr(i, 1) & "|" & arr(i, 2)
        End If
    Next
    last_row = .Cells(Rows.Count, 1).End(xlUp).Row + 1
    '将新的记录写入到数据源
    For Each Key In d.keys
        .Cells(last_row, 1).Resize(1, 2) = Split(Key, "|")
        .Cells(last_row, 3).Resize(1, 3) = d(Key)
        .Cells(last_row, 6).Value2 = .Cells(i, 5).Value2 / .Cells(i, 3).Value2
        last_row = last_row + 1
    Next
End With

Application.ScreenUpdating = True
End Sub
 
字典求和和计数同时进行
 
有了加总与计数，也可以求平均值：sum/count
 
Sub test()
Dim d As Object
Dim key_cnt As Long
Dim key As String

Det d = CreateObject("scripting.dictionary")
arr = ActiveSheet.UsedRange
For i = 2 To UBound(arr)
    key = Join(Array(arr(i, 2), arr(i, 3)), "|")
    '如果字典该条键存在，累加
    If d.exists(key) Then
        key_cnt = d(key)(0) + 1    '天数，计数+1
        val_sum = d(key)(1) + arr(i, 4)      '指标值加总
        d(key) = Array(key_cnt, val_sum)
    Else
        '如果不存在，计数计算为1
        d(key) = Array(1, arr(i, 4))
    End If
Next
' 求平均数
for k in d.keys
	' 键 = array(计数，求和，平均数）
	d(k) = array(d(k)(0),d(k)(1),d(k)(1) / d(k)(0)   ' 数组的第一个元素下标是0
next

End Sub
 
类似sql的join操作
 
有点像hive里面的mapjoin逻辑
 示例：游戏名称join关联游戏类型
 
 
Sub filter()
Application.ScreenUpdating = False

' 使用筛选过滤
Dim arr
Dim brr()
Dim d As Object
Dim i As Byte
Dim row As Byte

Set d = CreateObject("scripting.dictionary")
With ActiveSheet
    ' 把游戏品类写入到字典
    arr = .Range("f2:g4")
    For i = 1 To UBound(arr)
        d(arr(i, 1)) = arr(i, 2)
    Next
    
    ' 筛选头部游戏数据
    arr = .Range("a2:c11")
    row = 0
    ReDim brr(1 To 4, 1 To 1)
    For i = 1 To UBound(arr)
        If d.exists(arr(i, 1)) Then     ' 如果是精品游戏，则返回这一行记录
            row = row + 1
            ReDim Preserve brr(1 To 4, 1 To row)
            brr(1, row) = arr(i, 1)
            brr(2, row) = arr(i, 2)
            brr(3, row) = arr(i, 3)
            brr(4, row) = d(arr(i, 1)) ' 匹配游戏品类
        End If
    Next
    
    ' 输出
    .Range("j1:m1").Copy .Range("j10")
    .Range("j11").Resize(UBound(brr, 2), 4) = Application.WorksheetFunction.Transpose(brr)
End With

Application.ScreenUpdating = True  ' 恢复复屏幕刷新
End Sub