|
这个没什么难的,就是比较烦,对来对去眼都花了。- Sub 生成短信()
- Set d = CreateObject("scripting.dictionary")
- Set d1 = CreateObject("scripting.dictionary")
- arr = Sheets("通讯录").[a1].CurrentRegion '通讯录
- For i = 1 To UBound(arr)
- d(arr(i, 1) & arr(i, 2)) = arr(i, 3) '姓名+部门为key,短号为item
- d1(arr(i, 1) & arr(i, 2)) = arr(i, 4) '姓名+部门为key,长号为item
- Next
- Dim LongTel
- With Sheets("全校")
- arr = .[a1].CurrentRegion
- ReDim brr(1 To UBound(arr), 1 To 9)
- For i = 4 To UBound(arr)
- LongTel = ""
- n = n + 1
- brr(n, 1) = arr(i, 1) '日期
- brr(n, 2) = arr(i, 2) '星期
- For j = 3 To 7
- m = 4 * (j - 3) + 3
- k1 = arr(i, m) & arr(i, m + 1): k2 = arr(i, m + 2) & arr(i, m + 3)
- If d.exists(k1) Then brr(n, j) = arr(i, m) & d(k1)
- If d.exists(k2) Then brr(n, j) = brr(n, j) & Chr(10) & arr(i, m + 2) & d(k2) '姓名+短号
- Next
-
- For k = 1 To 4 '今日晚班长号
- p = IIf(k = 1, 7, IIf(k = 2, 9, IIf(k = 3, 15, 17)))
- xkey = arr(i, p) & arr(i, p + 1)
- If d1.exists(xkey) Then LongTel = LongTel & "," & d1(xkey)
- Next
- If i < UBound(arr) Then '明日白班长号
- For k = 1 To 6
- p = IIf(k = 1, 3, IIf(k = 2, 5, IIf(k = 3, 11, IIf(k = 4, 13, IIf(k = 5, 19, 21)))))
- xkey = arr(i + 1, p) & arr(i + 1, p + 1)
- If d1.exists(xkey) Then LongTel = LongTel & "," & d1(xkey)
- Next
- End If
- brr(n, 8) = "'" & Mid(LongTel, 2)
- Next
-
- For i = 1 To n '短信内容
- a1 = "": a2 = "": a3 = "": a4 = "": a5 = ""
- If brr(i, 4) <> "" Then a1 = " 今天晚班值班的北校区人员是(" & Replace(brr(i, 4), Chr(10), ",") & ")"
- If brr(i, 6) <> "" Then a2 = ",南校区人员是(" & Replace(brr(i, 6), Chr(10), ",") & ")" & Chr(10)
- If i < n Then
- If brr(i + 1, 3) <> "" Then a3 = " 明天白天值班的北校区人员是(" & Replace(brr(i + 1, 3), Chr(10), ",") & ")"
- If brr(i + 1, 5) <> "" Then a4 = ",南校区人员是(" & Replace(brr(i + 1, 5), Chr(10), ",") & ")"
- If brr(i + 1, 7) <> "" Then a5 = ",东校区人员是(" & Replace(brr(i + 1, 7), Chr(10), ",") & ")"
- End If
- brr(i, 9) = a1 & a2 & a3 & a4 & a5
- Next
- End With
- With Sheet3
- .Rows("3:100").ClearContents
- .[a3].Resize(n, 9) = brr
- .Rows("3:" & 3 + n).AutoFit
- End With
- End Sub
复制代码 |
|