各qudong楼盘点击及电话直聊情况

Option Explicit
Dim rwbk As Workbook
Dim rsht As Worksheet
'…………………………………………………………………………………各区董楼盘点击及电话直聊情况……………………………………………………………………………………………………………………………………
Sub qdallestate()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Call qdallestate1

Call qdallestate2

Call qdallestate3

Call qdallestate4

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub



'………………………………1.新建结果文档并处理导出的关键词报表………………………………………………………………
Sub qdallestate1()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'打开结果文档
Dim str1 As String
str1 = Dir("d:\Users\zhanggl21\Desktop\6666\上月各区董楼盘点击及电话直聊情况(所有楼盘)\*各区董楼盘点击及电话直聊情况*.xlsx", vbNormal)
Workbooks.Open Filename:="d:\Users\zhanggl21\Desktop\6666\上月各区董楼盘点击及电话直聊情况(所有楼盘)\" & str1
ActiveSheet.Rows("2:50000").ClearContents
ActiveSheet.Name = Year(Now()) & "年" & Month(Now()) - 1 & "月结果表"
'定义结果表
Set rsht = ActiveSheet

'定义结果文档
Set rwbk = ActiveWorkbook

'新建1张表
Sheets.Add after:=Sheets(Sheets.Count), Count:=2
Sheets(2).Name = "关键词"
Sheets(3).Name = "暂存"

'打开关键词报表
Dim str2 As String
str2 = Dir("d:\Users\zhanggl21\Desktop\6666\上月各区董楼盘点击及电话直聊情况(所有楼盘)\*关键词*", vbNormal)
Workbooks.Open Filename:="d:\Users\zhanggl21\Desktop\6666\上月各区董楼盘点击及电话直聊情况(所有楼盘)\" & str2
'删除无效行与列
Rows("1:3").Delete
Columns("a").Delete
Rows("2").Delete
Rows(Cells(1, 1).End(xlDown).Row & ":100000").Delete
'筛选所需数据
ActiveSheet.UsedRange.AutoFilter field:=2, Criteria1:="*战区*", Operator:=xlFilterValues
Range("a1:h100000").SpecialCells(xlCellTypeVisible).Copy Destination:=rwbk.Sheets("关键词").Range("a1")
'关闭关键词报表文档
ActiveWorkbook.Close savechanges:=False

'跳转到结果文档的关键词表
Application.Goto rwbk.Sheets("关键词").Range("a1")
'提取区董姓名(并删除匹配不到的记录)
Columns("d").Insert
Range("d1") = "区董"
With Range("d2:d" & Cells(1, 1).End(xlDown).Row)
    .Formula = "=MID(B2,SEARCH(""("",B2)+1,SEARCH(""-"",B2,5)-1-SEARCH(""("",B2))"
    .Value = .Value
    .SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete
End With

'删除无用的列
Range("b:c").Delete

'新增3列
Dim ac As Byte
ac = Cells(1, 1).End(xlToRight).Column
Cells(1, ac + 1).Resize(1, 9) = Array("平均访问时长s", "跳出次数", "访问时长", "总浏览量", "总访问次数", "总跳出次数", "总访问时长", "平均访问时长(终)", "跳出率(终)")

'将平均访问时长转化为s
Dim rcl As Long
rcl = Cells(1, 1).End(xlDown).Row
With Range(Cells(2, ac + 1), Cells(rcl, ac + 1))
    .Formula = "=timevalue(rc[-1])"
    .Value = .Value
    .NumberFormat = "[s]"
End With
'删除原来的平均访问时长字段列
Columns(ac).Delete

'填充跳出次数
With Range(Cells(2, ac + 1), Cells(rcl, ac + 1))
    .Formula = "=rc[-2]*rc[-3]"
    .Value = .Value
End With

'填充访问时长
With Range(Cells(2, ac + 2), Cells(rcl, ac + 2))
    .Formula = "=rc[-2]*rc[-4]"
    .Value = .Value
    .NumberFormat = "[s]"
End With

'填充总浏览量
With Range(Cells(2, ac + 3), Cells(rcl, ac + 3))
    .Formula = "=SUMIFS(C:C,B:B,B2,A:A,A2)"
    .Value = .Value
    .NumberFormat = "general"
End With

'填充总访问次数
With Range(Cells(2, ac + 4), Cells(rcl, ac + 4))
    .Formula = "=SUMIFS(d:d,B:B,B2,A:A,A2)"
    .Value = .Value
    .NumberFormat = "general"
End With

'填充总跳出次数
With Range(Cells(2, ac + 5), Cells(rcl, ac + 5))
    .Formula = "=SUMIFS(g:g,B:B,B2,A:A,A2)"
    .Value = .Value
    .NumberFormat = "general"
End With

'填充总访问时长
With Range(Cells(2, ac + 6), Cells(rcl, ac + 6))
    .Formula = "=SUMIFS(h:h,B:B,B2,A:A,A2)"
    .Value = .Value
    .NumberFormat = "[s]"
End With

'填充平均访问时长
With Range(Cells(2, ac + 7), Cells(rcl, ac + 7))
    .Formula = "=rc[-1]/rc[-3]"
    .Value = .Value
    .NumberFormat = "[s]"
End With

'填充跳出率
With Range(Cells(2, ac + 8), Cells(rcl, ac + 8))
    .Formula = "=rc[-3]/rc[-4]"
    .Value = .Value
    .NumberFormat = "0.00%"
End With

'将所需结果单独复制出来
Application.Union(Columns("a:b"), Columns(ac + 3), Columns(ac + 7), Columns(ac + 8)).Copy Destination:=[s1]

'将结果去重
Columns("s").Resize(, 5).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), Header:=xlYes

'将列名“关键词”修改为“楼盘名称”,将列名“总浏览量”修改为“浏览量”
With Range("s1").Resize(, 5)
    .Find(what:="关键词", lookat:=xlPart) = "楼盘名称"
    .Find("总浏览量", lookat:=xlPart) = "浏览量"
'调整各列位置
    Columns(.Find(what:="区董", lookat:=xlPart).Column).Cut
    Columns("s").Insert shift:=xlToRight
    Columns(.Find(what:="跳出率(终)", lookat:=xlPart).Column).Cut
    Columns("v").Insert shift:=xlToRight
    .Find(what:="跳出率(终)", lookat:=xlPart) = "跳出率"
    .Find("平均访问时长(终)", lookat:=xlPart) = "平均访问时长"
End With

'复制到结果表
Range(Range("s2"), Range("w" & Range("s1").End(xlDown).Row)).Copy
rsht.Activate
[b2].PasteSpecial Paste:=xlPasteValues

'将楼盘名称复制到暂存表的M列
Columns("c").Copy Destination:=Sheets("暂存").Range("g1")


End Sub










'…………………………………………2.将在关键词报表中未出现的楼盘复制到结果表………………………………………………………………………………

Sub qdallestate2()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'打开上周的房源明细表
Dim str2 As String
str2 = Dir("d:\Users\zhanggl21\Desktop\6666\上月各区董楼盘点击及电话直聊情况(所有楼盘)\*中原网房源明细*.xlsx", vbNormal)
Workbooks.Open Filename:="d:\Users\zhanggl21\Desktop\6666\上月各区董楼盘点击及电话直聊情况(所有楼盘)\" & str2

'将区董和楼盘名称两列复制到暂存表
Dim ik As Byte, jk As Byte
ik = Rows("1").Find("区董", lookat:=xlPart).Column
jk = Rows("1").Find("楼盘名称", lookat:=xlPart).Column
Union(Columns(ik), Columns(jk)).Copy

Application.Goto rwbk.Sheets("暂存").Range("a1")
Range("a1").PasteSpecial Paste:=xlPasteValues

'关掉房源明细表
Workbooks(str2).Close savechanges:=False

'将暂存表里的楼盘名称分列处理
With Columns(2)
    .TextToColumns DataType:=xlDelimited, other:=True, otherchar:="("
    .TextToColumns DataType:=xlDelimited, other:=True, otherchar:="（"
    .TextToColumns DataType:=xlDelimited, other:=True, otherchar:="-"
End With

'删除多余列
'Columns("c:h").Delete

'区董与楼盘去重
Columns("a:b").RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes

'筛选在结果表里未出现的楼盘
Range("c1") = "筛选楼盘"
With Range("c2:c" & Cells(1, 1).End(xlDown).Row)
    .Formula = "=IF(ISERROR(VLOOKUP(B2,g:g,1,0)),1,0)"
    .Value = .Value
End With

'筛选出所需楼盘和区董
Range("a:c").AutoFilter field:=3, Criteria1:="1", Operator:=xlFilterValues
Range("a2:b50000").SpecialCells(xlCellTypeVisible).Copy

'将所需楼盘和区董复制到结果表
rsht.Activate
Cells(Cells(1, 2).End(xlDown).Row, 2).Offset(1, 0).PasteSpecial Paste:=xlPasteValues


'填充浏览量列
Columns("d").SpecialCells(xlCellTypeBlanks).Select
Selection.Value = 0

'填充跳出率列
Columns("e").SpecialCells(xlCellTypeBlanks).Select
Selection.Value = "无"

'填充平均访问时长(s)列
Columns("f").SpecialCells(xlCellTypeBlanks).Select
Selection.Value = "无"


End Sub












'…………………………………………3.匹配出所有楼盘的电话与直聊量………………………………………………………………………………

Sub qdallestate3()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'打开上月的各楼盘电话及直聊量
Dim str3 As String
str3 = Dir("d:\Users\zhanggl21\Desktop\6666\上月各区董楼盘点击及电话直聊情况(所有楼盘)\*各区董下属楼盘直聊电话*.xlsx", vbNormal)
Workbooks.Open Filename:="d:\Users\zhanggl21\Desktop\6666\上月各区董楼盘点击及电话直聊情况(所有楼盘)\" & str3

Application.Goto Sheets("R电话").Range("a1")
Range("k:l").Copy Destination:=rsht.Range("l1")

Application.Goto Sheets("R直聊").Range("a1")
Range("k:l").Copy Destination:=rsht.Range("p1")

ActiveWorkbook.Close savechanges:=False

'计算出各楼盘的直聊回复率
Dim str4 As String
str4 = Dir("d:\Users\zhanggl21\Desktop\6666\上月各区董楼盘点击及电话直聊情况(所有楼盘)\*直聊.xlsx", vbNormal)
Workbooks.Open Filename:="d:\Users\zhanggl21\Desktop\6666\上月各区董楼盘点击及电话直聊情况(所有楼盘)\" & str4

'将所需数据复制到结果文档的[关键词]表
ActiveSheet.UsedRange.AutoFilter field:=17, Criteria1:="<>"
Dim aa As Byte
Dim bb As Byte
Dim cc As Byte
aa = Rows("1").Find("序号", lookat:=xlPart).Column
bb = Rows("1").Find("回复数", lookat:=xlPart).Column
cc = Rows("1").Find("小区", lookat:=xlPart).Column

Union(Columns(aa), Columns(bb), Columns(cc)).Copy

rsht.Activate

[t1].PasteSpecial xlPasteValues
Columns("t").Resize(, 3).RemoveDuplicates Columns:=Array(1, 2, 3)

'关闭直聊表
Workbooks(str4).Close savechanges:=False


Dim mm As Integer
mm = [u1].End(xlDown).Row

[w1] = "经纪人回复情况"
[x1] = "直聊回复率"

With Range(Cells(2, 23), Cells(mm, 23))
    .Formula = "=IF(U2>0,1,0)"
    .Value = .Value
End With

With Range(Cells(2, 24), Cells(mm, 24))
    .Formula = "=SUMIF(V:V,V2,W:W)/COUNTIF(V:V,V2)"
    .Value = .Value
    .NumberFormat = "0%"
End With



End Sub





'…………………………………………4.匹配出所有楼盘的电话与直聊量与直聊回复率………………………………………………………………………………

Sub qdallestate4()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'匹配出各楼盘的来电量与直聊量与直聊回复率
Dim kk As Integer
kk = [c1].End(xlDown).Row

'匹配电话量
With Range(Cells(2, 7), Cells(kk, 7))
    .Formula = "=VLOOKUP(C2,L:M,2,0)"
    .Value = .Value
End With

'匹配直聊量
With Range(Cells(2, 8), Cells(kk, 8))
    .Formula = "=VLOOKUP(C2,p:q,2,0)"
    .Value = .Value
End With


'匹配直聊回复率
With Range(Cells(2, 9), Cells(kk, 9))
    .Formula = "=VLOOKUP(C2,V:X,3,0)"
    .Value = .Value
End With


'来电量匹配不到的标记为０
Range("g:g").SpecialCells(xlCellTypeConstants, xlErrors) = 0

'直聊量匹配不到的标记为０
Range("h:h").SpecialCells(xlCellTypeConstants, xlErrors) = 0

'直聊回复率匹配不到的标记为"无"
Range("i:i").SpecialCells(xlCellTypeConstants, xlErrors) = "无"


Columns("k:z").Delete

'填入时间字段
Range(Cells(2, 1), Cells(kk, 1)) = Year(Now()) & "年" & Month(Now()) - 1 & "月"


'把多余楼盘删掉
Range("j1") = "筛选"
With Range(Cells(2, 10), Cells(kk, 10))
    .Formula = "=countif(c:c,c2)"
    .Value = .Value
End With
ActiveSheet.UsedRange.AutoFilter field:=10, Criteria1:=">1"
Rows("2:20000").SpecialCells(xlCellTypeVisible).Delete
ActiveSheet.AutoFilterMode = False

Columns("j").Delete


'把直聊量为0且直聊回复率>0的记录删掉
ActiveSheet.UsedRange.AutoFilter field:=9, Criteria1:="无"
ActiveSheet.UsedRange.AutoFilter field:=8, Criteria1:=">0"
Rows("2:20000").SpecialCells(xlCellTypeVisible).Delete
ActiveSheet.AutoFilterMode = False

'把区董为"-"的记录删掉
ActiveSheet.UsedRange.AutoFilter field:=2, Criteria1:="-"
Rows("2:20000").SpecialCells(xlCellTypeVisible).Delete
ActiveSheet.AutoFilterMode = False


'格式调整
Range("a2:i2").Copy
Range("a2:i" & Cells(1, 1).End(xlDown).Row).PasteSpecial (xlPasteFormats)


'按区董为主关键词、浏览量为次关键词、楼盘名称为次关键词升序排列
ActiveSheet.UsedRange.Sort key1:=Range("b1"), order1:=xlAscending, key2:=Range("d1"), order2:=xlDescending, Header:=xlYes, Orientation:=xlTopToBottom



'删除后两个sheet
Sheets(Array(2, 3)).Delete

ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path & "\" & Year(Now()) & "年" & Month(Now()) - 1 & "月各区董楼盘点击及电话直聊情况(所有楼盘)-新.xlsx"

ActiveWorkbook.Close savechanges:=False

End Sub