首页 最新文章网站编程正文

用VBA制作的流量日报做成工具

Dim loaddate As String, pr As String, pv As String, uv As String, newvisitor_percent As String, collection As String
Dim article As String, outside_chain As String, semshow As String, semclick As String, semconsume As String
Dim splitnull As String, semflow As String, semorders As String, semrate As String, seoflow As String, seoorders As String
Dim seorate As String, samllroutineflow As String, samllroutineorders As String, samllroutinerate As String, otherflow As String
Dim otherorders As String, otherrate As String, bak1 As String, bak2 As String, bak3 As String, bak4 As String, bak5 As String, bak6 As String
Dim oConn As New ADODB.Connection             '定义mysql数据源(需要先在本地安装驱动及创建好数据源)
'******************************************************************************************************************************
'*程序名称:流量日报表自动作成
'*作    者:liuxiangtao
'*发布版本:Ver1.0
'*发布日期:2019-11-23  初版作成
'*函数构成:1、主函数:getreport
                  '2、接口数据获取函数:GetDatafromapi
                  '3、DB数据获取函数:getDatafromdb
                  '4、数据沉淀函数:Putdata
'*数据来源:百度统计、百度推广、Matomo
'*主要约束:1、权重、收录量无官方API;
                  '2、文章数、外链数依赖人工;
                  '3、SEO及SEM流量数据查询的是总量,日报以天为单位查询需要反复调接口,效率不高
                  '4、日报模板必须固定,若有调整需要调整程序
'*主要逻辑:创建数据沉淀表,根据用户查询日期和已沉淀的数据日期进行比较,若已沉淀,则直接生成结果
                  '否则先进行沉淀,沉淀过程分别从百度统计、百度推广和matomo获取数据,此过程最多调用两次百度api接口,解决效率问题
'******************************************************************************************************************************
Sub Getreport()
        Form_date1.Hide
        Dim Dstart_date As String, Dend_date As String, maxdate As String
        
        'yyyymmdd格式的日期
        Dstart_date = Form_date1.ComboBox1.Value & Form_date1.ComboBox2.Value & Form_date1.ComboBox3.Value
        Dend_date = Form_date1.ComboBox6.Value & Form_date1.ComboBox5.Value & Form_date1.ComboBox4.Value
        
        'yyyy/mm/dd格式的日期
        DDstart_date = Form_date1.ComboBox1.Value & "/" & Form_date1.ComboBox2.Value & "/" & Form_date1.ComboBox3.Value
        DDend_date = Form_date1.ComboBox6.Value & "/" & Form_date1.ComboBox5.Value & "/" & Form_date1.ComboBox4.Value
        
        maxdate = ""
        '模板检查
        If Cells(1, 1).Value <> "推广数据统计" Or Cells(1, 13).Value <> "效果数据" Or Cells(3, 2).Value <> "权重" Or Cells(3, 9).Value <> "展现" Or Cells(3, 13).Value <> "流量" Then
            MsgBox ("请打开每日报表的模板或请确认报表模板是否有调整")
            Exit Sub
        Else
            '清空数据
            Range("A4:X400").ClearContents
            
            '禁止刷新,提升速度
            application.ScreenUpdating = False
            
            '转化率列的格式化(百分比)
            Range("O4:O400").NumberFormatLocal = "0.00%"
            Range("R4:R400").NumberFormatLocal = "0.00%"
            Range("U4:U400").NumberFormatLocal = "0.00%"
            
            '连接mysql数据库
            oConn.ConnectionString = "Driver={MySQL ODBC 8.0 Unicode Driver};Server=rm-bp179ar5909n2w4qjpo.mysql.RDS.aliyuncs.com;PORT=3306;DB=matomo;UID=report;PWD=Aa111111$$;OPTION=3;"
            oConn.Open
            '判断是否能够正常连接数据库
            If oConn.State <> 1 Then
                Set oConn = Nothing
                MsgBox "数据库联接失败!"
                Exit Sub
            End If
            
            '定义sql语句变量
            Dim strSQL As String, selectDateSQL As String
            
            '从matomo数据库获数据的sql
            strSQL = ""
            strSQL = "SELECT  loaddate,   pr,   CONVERT (pv, signed),   CONVERT (uv, signed),   CONVERT (newvisitor_percent, decimal(18,2)),   collection, "
            strSQL = strSQL & "  article,  outside_chain, convert (semshow, signed),  convert (semclick, signed), CONVERT (semconsume, decimal(18,5)),"
            strSQL = strSQL & "  split, CONVERT (semflow, signed),  CONVERT (semorders, signed),    CONVERT (semrate, decimal(18,5)),  CONVERT (seoflow, signed),"
            strSQL = strSQL & "  CONVERT (seoorders, signed), CONVERT (seorate,  decimal(18,5)),  CONVERT (samllroutineflow, signed), CONVERT (samllroutineorders, signed),"
            strSQL = strSQL & "  CONVERT (samllroutinerate,  decimal(18,5)),CONVERT (otherflow, signed),CONVERT (otherorders, signed),CONVERT (otherrate,decimal(18,5))"
            strSQL = strSQL & " FROM ma_product_everyday_report  WHERE  loaddate >= '" & DDstart_date & "' and " & " loaddate <= '" & DDend_date & "' order by loaddate desc"
            
            'matomo沉淀数据的最新日期
            selectDateSQL = ""
            selectDateSQL = "select date_format(max(loaddate),'%Y/%m/%d') from ma_product_everyday_report"
            
            'Cells(30, 1).Value = strSQL
            
            '定义数据源执行结果对象
            Dim rstMain As ADODB.Recordset, rstMain_1 As ADODB.Recordset
            Set rstMain = New ADODB.Recordset
            '执行sql获取沉淀数据的最新日期
            rstMain.Open selectDateSQL, oConn, 3, 3
            '将查询的最新日期存起来
            maxdate = rstMain.Fields.Item(0)
            
            '通过和用户输入的查询日期比较,判断是从百度API取数据还是从DB直接取数据
            If DateDiff("d", DDend_date, maxdate) >= 0 Then  '想查询的数据都在数据库里
                '
            Else    '沉淀的数据不满足用户的需要
                Dim insDate As String, putsum As Integer
                putsum = 0
                '看看还差多少数据没沉淀
                For k = 1 To DateDiff("d", maxdate, DDend_date)
                    '待沉淀数据的日期
                    insDate = CDate(maxdate) + k
                    '调用数据沉淀函数
                    Call Putdata(insDate)
                    Call ShowPercentMsg("第" & k & "条数据沉淀中")
                    putsum = putsum + 1
                Next k
            End If
            
            Set rstMain_1 = New ADODB.Recordset
            rstMain_1.Open strSQL, oConn, 3, 3
            Range("A4").CopyFromRecordset rstMain_1
            
            '关闭数据库连接
            rstMain.Close: Set rstMain = Nothing
            rstMain_1.Close: Set rstMain_1 = Nothing
        End If
        oConn.Close: Set oConn = Nothing
        APPlication.ScreenUpdating = True
        MsgBox ("It's ok,本次共沉淀" & putsum & "条数据")
End Sub
'从百度api抽取数据并沉淀到本地数据库
'参数:待沉淀数据的日期
Function Putdata(Put_date As String)
        '通过api获取数据一部分沉淀数据
        Call GetDatafromapi(Put_date, Put_date)
        '通过matomo获取一部分沉淀数据
        Call getDatafromdb(Put_date, Put_date)
        loaddate = Left(Put_date, 4) & "/" & Mid(Put_date, 5, 2) & "/" & Right(Put_date, 2)  '沉淀数据_日期
        pr = "" 'PR
        collection = "" '收录量
        article = ""  '文章量
        outside_chain = "" '外链量
        splitnull = "" '分格列(无意义)
        semrate = FormatNumber(semorders / semflow, 5, -1) 'SEM转化率
        seorate = FormatNumber(seoorders / seoflow, 5, -1)   'SEO转化率
        samllroutinerate = FormatNumber(samllroutineorders / samllroutineflow, 5, -1)  '小程序转化率
        otherrate = FormatNumber(otherorders / otherflow, 5, -1)   '快排转化率
        '以下为备用字段
        bak1 = ""
        bak2 = ""
        bak3 = ""
        bak4 = ""
        bak5 = ""
        bak6 = ""
        '定义sql语句变量
        Dim insSQL As String
        '初始化
        insSQL = ""
        insarr = Array(loaddate, pr, pv, uv, newvisitor_percent, collection, article, outside_chain, semshow, semclick, semconsume, splitnull, semflow, semorders, semrate, seoflow, seoorders, seorate, samllroutineflow, samllroutineorders, samllroutinerate, otherflow, otherorders, otherrate, bak1, bak2, bak3, bak4, bak5, bak6)
        insSQL = "INSERT INTO ma_product_everyday_report (loaddate,pr,pv,uv,newvisitor_percent,collection,article,outside_chain,semshow,semclick,semconsume,split,semflow,semorders,semrate,seoflow,seoorders,seorate,samllroutineflow,samllroutineorders,samllroutinerate,otherflow,otherorders,otherrate,bak1,bak2,bak3,bak4,bak5,bak6)  VALUES "
        insSQL = insSQL & "('" & Join(insarr, "','") & "')"
        
        '定义数据源执行结果对象
        Dim INSRecords As ADODB.Recordset
        Set INSRecords = New ADODB.Recordset
        '执行sql获取结果,adLockOptimistic表示执行过程中,数据可以正常操作
        Set INSRecords = oConn.Execute(insSQL)
End Function
'通过api获取数据
'参数:起止日期
Function GetDatafromapi(SDate As String, EDate As String)
    
        Dim Dstart_date As String, Dend_date As String
        '共通header信息
        SentUrl = "https://api.baidu.com/json/tongji/v1/ReportService/getData"
        DuserName = "username"
        Dpassword = "passwd"
        Dtoken = "xxxxxxxxxxxxxxxxxx"
        Daccount_type = 1
        
        '共通body信息
        Dsite_id = "12718727,12718732"
        Dstart_date = SDate
        Dend_date = EDate
        '网站整体的body信息
        Dmetrics = "pv_count,visitor_count,new_visitor_ratio"
        Dmethod = "trend/time/a"
        Dgran = "day"
        Darea = ""
        
        'SEO的body信息
        SEODmetrics = "visitor_count"
        SEODmethod = "source/engine/a"
        SEODarea = ""
    
        'SEM的body信息
        SEMDmetrics = "show_count,clk_count,cost_count,visitor_count"
        SEMDmethod = "pro/product/a"
        SEMDarea = ""
        
        '初始化
        Return_Data = ""
        SEOReturnData = ""
        SEMReturnData = ""
        Dim tempDB()
        
        '共通post header(Json格式)
        post_header = "{" & Chr(34) & "header" & Chr(34) & ":{" & Chr(34) & "username" & Chr(34) & ":" & Chr(34) & DuserName & Chr(34) & "," & Chr(34) & "password" & Chr(34) & ":" _
                            & Chr(34) & Dpassword & Chr(34) & "," & Chr(34) & "token" & Chr(34) & ":" & Chr(34) & Dtoken & Chr(34) & "," & Chr(34) & "account_type" & Chr(34) & ":1}"
                            
        '网站整体post body(Json格式)
        post_body = Chr(34) & "body" & Chr(34) & ":{" & Chr(34) & "site_id" & Chr(34) & ":" & Chr(34) & Dsite_id & Chr(34) & "," & Chr(34) & "start_date" & Chr(34) & ":" _
                            & Chr(34) & Dstart_date & Chr(34) & "," & Chr(34) & "end_date" & Chr(34) & ":" & Chr(34) & Dend_date & Chr(34) & "," & Chr(34) & "metrics" & Chr(34) & ":" _
                            & Chr(34) & Dmetrics & Chr(34) & "," & Chr(34) & "method" & Chr(34) & ":" & Chr(34) & Dmethod & Chr(34) & "," & Chr(34) & "gran" & Chr(34) & ":" _
                            & Chr(34) & Dgran & Chr(34) & "," & Chr(34) & "area" & Chr(34) & ":" & Chr(34) & Darea & Chr(34) & "}}"
        post_data = post_header & "," & post_body
      '网站总体数据抽取及输出------------------------------------------------------------------
        With CreateObject("Microsoft.XMLhttp")
            .Open "post", SentUrl, False
            .setrequestheader "Content-type", "application/json;charset=utf-8"
            .send post_data
            ReturnData = .responseText
        End With
        
        arr = split(Replace(Replace(Replace(ReturnData, "[[[", "],["), "[[", "["), "]]", "]"), "],[")  '格式化json数据后存储到数组
        DataSum = UBound(arr) - 5   '数组中有效数据个数包括日期和PUV
        PUV_visitor = split(arr(2), ",")  '拆分PV和UV值
        SEODstart_date = Replace(arr(1), Chr(34), "")
        SEODend_date = Replace(arr(1), Chr(34), "")
        pv = PUV_visitor(0)
        uv = PUV_visitor(1)
        newvisitor_percent = PUV_visitor(2)
        Call ShowPercentMsg("API获取数据中")
        
    'SEO及SEM数据抽取及输出------------------------------------------------------------------
         SEO_post_body = Chr(34) & "body" & Chr(34) & ":{" & Chr(34) & "site_id" & Chr(34) & ":" & Chr(34) & Dsite_id & Chr(34) & "," & Chr(34) & "start_date" & Chr(34) & ":" _
                            & Chr(34) & SEODstart_date & Chr(34) & "," & Chr(34) & "end_date" & Chr(34) & ":" & Chr(34) & SEODend_date & Chr(34) & "," & Chr(34) & "metrics" & Chr(34) & ":" _
                            & Chr(34) & SEODmetrics & Chr(34) & "," & Chr(34) & "method" & Chr(34) & ":" & Chr(34) & SEODmethod & Chr(34) & "," & Chr(34) & "area" & Chr(34) & ":" _
                            & Chr(34) & SEODarea & Chr(34) & "}}"
                            
         SEM_post_body = Chr(34) & "body" & Chr(34) & ":{" & Chr(34) & "site_id" & Chr(34) & ":" & Chr(34) & Dsite_id & Chr(34) & "," & Chr(34) & "start_date" & Chr(34) & ":" _
                            & Chr(34) & SEODstart_date & Chr(34) & "," & Chr(34) & "end_date" & Chr(34) & ":" & Chr(34) & SEODend_date & Chr(34) & "," & Chr(34) & "metrics" & Chr(34) & ":" _
                            & Chr(34) & SEMDmetrics & Chr(34) & "," & Chr(34) & "method" & Chr(34) & ":" & Chr(34) & SEMDmethod & Chr(34) & "," & Chr(34) & "area" & Chr(34) & ":" _
                            & Chr(34) & SEMDarea & Chr(34) & "}}"
                            
        seo_post_data = post_header & "," & SEO_post_body
        sem_post_data = post_header & "," & SEM_post_body
    
       'SEO数据处理及输出
        With CreateObject("Microsoft.XMLHTTP")
            .Open "post", SentUrl, False
            .setrequestheader "Content-type", "application/json;charset=utf-8"
            .send seo_post_data
            SEOReturnData = .responseText
        End With
        SEOarr = split(Replace(Replace(Replace(SEOReturnData, "[[[", "],["), "[[", "["), "]]", "]"), "],[") '格式化json数据后存储到数组
        SEOsum = split(SEOarr(UBound(SEOarr) - 3), ":[")
        seoflow = Replace(SEOsum(2), Chr(34), "")
        
       'SEM数据处理及输出
        With CreateObject("Microsoft.XMLHTTP")
            .Open "post", SentUrl, False
            .setrequestheader "Content-type", "application/json;charset=utf-8"
            .send sem_post_data
            SEMReturnData = .responseText
        End With
        SEMarr = split(Replace(Replace(Replace(SEMReturnData, "[[[", "],["), "[[", "["), "]]", "]"), "],[") '格式化json数据后存储到数组
        SEMsum = split(SEMarr(4), ":[")
        SEM = split(Replace(SEMsum(2), Chr(34), ""), ",")
        semshow = SEM(0)
        semclick = SEM(1)
        semconsume = SEM(2)
        semflow = SEM(3)
        'Call getDatafromdb(Dstart_date, Dend_date)
End Function
'matomo中查询SEO和SEM的订单数
'参数:日期区间
Function getDatafromdb(StartDate As String, EndDate As String)
    StartDate = Replace(StartDate, "/", "")
    EndDate = Replace(EndDate, "/", "")
    '定义sql语句变量
    Dim strSQL1 As String, strSQL3 As String
    '初始化
    strSQL1 = ""
    strSQL3 = ""
    '待执行sql语句
    
    'SEM、SEO、小程序、快排订单
    strSQL1 = "SELECT sum(case when right(b.referer_name,2) in('pc','yd')  then 1 else 0 end) ,sum(case when (b.referer_type = '2' or b.referer_name in ('m.baidu.com','www.baidu.com','www.so.com','m.so.com','www.sogou.com','m.sogou.com','www.google.com','m.google.com','yz.m.sm.cn','m.sm.cn'))  then 1 else 0 end),"
    strSQL1 = strSQL1 & " sum(case when b.campaign_source in ('xiaochengxu','小程序')  then 1 else 0 end), sum(case when b.idsite in ('11','14')  then 1 else 0 end)"
    strSQL1 = strSQL1 & " FROM   ma_log_conversion_item a,   ma_log_conversion b WHERE   a.idorder = b.idorder"
    strSQL1 = strSQL1 & " AND DATE_FORMAT(DATE_ADD(a.server_time,INTERVAL 8 HOUR),'%Y%m%d') >= '" & StartDate & "'"
    strSQL1 = strSQL1 & " AND DATE_FORMAT(DATE_ADD(a.server_time,INTERVAL 8 HOUR),'%Y%m%d') <= '" & EndDate & "'"
    strSQL1 = strSQL1 & " group by DATE_FORMAT(DATE_ADD(a.server_time,INTERVAL 8 HOUR),'%Y%m%d') order by a.server_time desc"
    
    '小程序流量&快排流量
    strSQL3 = "SELECT sum(IF((campaign_source IN ('xiaochengxu', '小程序')),1,0)),sum(IF((idsite IN ('11', '14')),1,0)) FROM ma_log_visit WHERE"
    strSQL3 = strSQL3 & " DATE_FORMAT(DATE_ADD(visit_last_action_time,INTERVAL 8 HOUR),'%Y%m%d') >='" & StartDate & "'"
    strSQL3 = strSQL3 & " AND DATE_FORMAT(DATE_ADD(visit_last_action_time,INTERVAL 8 HOUR),'%Y%m%d') <='" & EndDate & "'"
    strSQL3 = strSQL3 & " GROUP BY DATE_FORMAT(DATE_ADD(visit_last_action_time,INTERVAL 8 HOUR),'%Y%m%d') ORDER BY visit_last_action_time DESC"
    Call ShowPercentMsg("Matomo获取数据中")
    '定义数据源执行结果对象
    Dim rstMain1 As ADODB.Recordset, rstMain3 As ADODB.Recordset
    '存储SEM、SEO、小程序、快排订单数据
    Set rstMain1 = New ADODB.Recordset
    rstMain1.Open strSQL1, oConn, 3, 3
    orderarr = rstMain1.GetRows
    
    '小程序流量&快排流量数据
    Set rstMain3 = New ADODB.Recordset
    rstMain3.Open strSQL3, oConn, 3, 3
    visitarr = rstMain3.GetRows
        
    '数据剥离
    semorders = orderarr(0, 0)
    seoorders = orderarr(1, 0)
    samllroutineorders = orderarr(2, 0)
    otherorders = orderarr(3, 0)
    samllroutineflow = visitarr(0, 0)
    otherflow = visitarr(1, 0)
    
    '关闭释放
    rstMain1.Close: Set rstMain1 = Nothing
    rstMain3.Close: Set rstMain3 = Nothing
End Function


评论

百度搜索

站点信息

  • 文章总数:511
  • 页面总数:7
  • 分类总数:29
  • 标签总数:869
  • 评论总数:286
  • 浏览总数:6900185
Copyright ©2019-2020.Powered by©刘相涛 辽ICP备14000512号-5