【VBAPlanet】日期调整与多条件匹配

主要知识点

1.循环语句
2.多条件匹配-条件判断-数组-字段
3.函数_日期类型转换

代码示例

Option Explicit

Dim wb As Workbook, sht As Worksheet, sht_info As Worksheet
Dim file_path As String, file_name As String
Dim dic As Object, dic_sn As Object, dic_zl As Object, dic_yh As Object, dic_xz As Object, dic_key As String
Dim arr_info As Variant, arr As Variant, i As Long, n As Long

Sub 月irr数据整理()
Dim tms As Date
Application.ScreenUpdating = False
    tms = Timer
    Call 首付月份整理
    Call 月irr匹配填充
Application.ScreenUpdating = True
MsgBox "太棒了！月irr数据已整理完毕。用时" & Format(Timer - tms, "0.00s"), 64
End Sub

Sub 首付月份整理()
Application.ScreenUpdating = False
    Set sht = ActiveWorkbook.Worksheets(1)      ' 将活动工作簿中第一个工作表对象赋给变量sht
    ' 填充表头名称
    sht.Range("M1") = "首付月份"
    ' 首付月份整理
    n = sht.Range("B1").CurrentRegion.Rows.Count     ' 取得活动工作表的行数，并赋值给n
    arr = sht.Range("B1:M" & n)      ' 把查询区域装入数组arr
    For i = 2 To UBound(arr)    ' 遍历查询区域
        arr(i, 12) = ""      ' 清空原结果
        If arr(i, 8) = "续租" Then
            arr(i, 12) = Application.Text(arr(i, 6), "####年##月")      ' 续租订单根据合同生效月份生成对应年月
        Else
            arr(i, 12) = Application.Text(arr(i, 5), "e年mm月")     ' 其他类型订单根据首付支付时间生成对应年月
        End If
    Next
    With sht
        .Range("B:M").NumberFormatLocal = "@"  ' 设置单元格为文本格式，避免文本数值变形
        .Range("B1:M" & n).Value = arr   ' 将数组放回整理表
    End With
    Set sht = Nothing
Application.ScreenUpdating = True
End Sub

Sub 月irr匹配填充()
Application.ScreenUpdating = False
    file_name = Dir(ActiveWorkbook.Path & "\" & "资金成本月irr基础表*.xlsx")     ' 根据工作簿名称，使用Dir函数遍历分析表工作簿
    file_path = ActiveWorkbook.Path & "\" & file_name     ' 将要获取的工作簿名称赋给变量file_path
    Set wb = GetObject(file_path)        ' 将变量file_path代表的工作簿对象赋给变量wb
    Set sht_info = wb.Worksheets(1)
    Set dic_sn = CreateObject("scripting.dictionary")      '设置字典对象，用于后面引用字典
    Set dic_zl = CreateObject("scripting.dictionary")
    Set dic_yh = CreateObject("scripting.dictionary")
    Set dic_xz = CreateObject("scripting.dictionary")
    arr_info = sht_info.UsedRange
    For i = 2 To UBound(arr_info)       ' 遍历数组arr_info，将数据装入字典，以备查询
        dic_key = arr_info(i, 1)    ' 使用“日期”作为字典的key
        dic_sn(dic_key) = arr_info(i, 2)    ' 对应的“月irr”作为字典的item
        dic_zl(dic_key) = arr_info(i, 3)
        dic_yh(dic_key) = arr_info(i, 4)
        dic_xz(dic_key) = arr_info(i, 5)
    Next
    Set sht = ActiveWorkbook.Worksheets(1)      ' 将活动工作簿中第一个工作表对象赋给变量sht
    ' 填充表头名称
    sht.Range("N1") = "月irr"
    n = sht.Range("B1").CurrentRegion.Rows.Count     ' 取得活动工作表的行数，并赋值给n
    arr = sht.Range("B1:N" & n)      ' 把查询区域装入数组arr
    For i = 2 To UBound(arr)    ' 遍历查询区域
        arr(i, 13) = ""
         ' 清空原结果
        dic_key = arr(i, 12)
        If arr(i, 8) <> "续租" Then
            If arr(i, 11) = "平台化" And dic_zl.exists(dic_key) Then     ' 如果字典key中存在对应的年月
                arr(i, 13) = dic_zl(dic_key)    ' 从字典中取对应的item，即“月irr”
            ElseIf arr(i, 8) = "48期" And dic_yh.exists(dic_key) Then
                arr(i, 13) = dic_yh(dic_key)
            ElseIf dic_sn.exists(dic_key) Then
                arr(i, 13) = dic_sn(dic_key)
            End If
        ElseIf arr(i, 8) = "续租" And dic_xz.exists(dic_key) Then
            arr(i, 13) = dic_xz(dic_key)
        End If
    Next
    With sht
        ' .Range("E:E").NumberFormatLocal = "0.00%"  ' 设置单元格为百分比格式
        .Range("B1:N" & n).Value = arr   ' 将数组放回整理表
    End With
    Set dic_sn = Nothing    ' 释放字典内存
    Set dic_zl = Nothing
    Set dic_yh = Nothing
    wb.Close SaveChanges:=False

    Set sht = Nothing
    Set wb = Nothing
    Set sht_info = Nothing

Application.ScreenUpdating = True
End Sub