【VBA字典数组201301班】C组-第二讲作业上交处

无聊的疯子 · 发表于 2013-11-11 21:48

本帖最后由无聊的疯子于 2013-11-13 22:26 编辑

本贴为 C组第二讲作业上交专用贴，其它组员勿入

本次作业的要求：
1.要求添加注释（不要求每行都添加，涉及到关键的部分必须有）
2.代码缩进
3.要求变量强制声明（在模块的顶端已添加 option explicit，不得修改），声明变量时对变量的类型不做要求。

上交作业时，直接贴代码即可，
为方便统计，请在回贴时输入 ID与编号
如：C02:monicaj

xdragon · 发表于 2013-11-11 22:43

本帖最后由 xdragon 于 2013-11-13 09:19 编辑

C08:xdragon
以下只贴填空处，并非完整代码。

练习一：
Dim arr, brr(), a, brrrow As Long, brrcol As Integer

arr = rgSource.Value '如果选择是多个区域的话，利用默认只将第一个区域赋值给数组的特性，可以去除后面的多选区域

'判断是否为数组（考虑只选择一个单元格的情况）

If IsArray(arr) = False Then

rgDest.Resize(1).Value = arr

Exit Sub

End If

'brrrow为brr的行号；brrcol为列号

brrrow = 1

ReDim brr(1 To bGroupCount, 1 To UBound(arr) * UBound(arr, 2) / bGroupCount)'根据输入的行高设置新数组的第二维上限

For Each a In arr

brrcol = brrcol + 1

If brrcol > UBound(brr, 2) Then brrcol = 1: brrrow = brrrow + 1'当brrcol大于brr第二维上限时，重置brrcol为1，行序号+1（相当于换行输入）

brr(brrrow, brrcol) = a

Next

'防止数据太少但行数设置过大，导出空值覆盖其他的数据（比如选择了10个数据，行数设置20行）

If brrcol = 1 And brrrow < bGroupCount Then

rgDest.Resize(brrrow).Value = brr

Else

rgDest.Resize(UBound(brr), UBound(brr, 2)).Value = brr

End If
复制代码
练习二（数组+replace+split）
strText = Mid(strText, i) '定位到网页中符合查询条件的部分

With Sheet4

.[a1] = strText '将查询到的网页代码导入单元格

.Range("A1").Replace "<*>", "", xlPart '利用excel的模糊替换功能把html符号都删除

Dim tmp() As String, brr() As String, counter As Integer, m As Byte

tmp = Split(Replace(.[a1].Value, " ", ""), Chr(10)) '将空白字符替换，并且按换行符切割字符串

m = 1: ReDim brr(1 To 6, 1 To 1) '定义导出数据的数组brr，并初始赋值列变量m

For i = 3 To UBound(tmp) '利用每6个元素有两个空单元格的特性做以下循环，当每6个元素的第一个不是日期格式的时候跳出循环

counter = counter + 1

If counter > 6 Then

   i = i + 2

   If IsDate(Left(tmp(i), Len(tmp(i)) - 1)) = False Then Exit For

   counter = 1

   m = m + 1

   ReDim Preserve brr(1 To 6, 1 To m)

End If

brr(counter, m) = Left(tmp(i), Len(tmp(i)) - 1)

Next

'清空原数据区域，将数组brr导入单元格

.UsedRange.Clear

.Range("A1") = strFind

.Range("A2").Resize(UBound(brr, 2), UBound(brr)) = Application.Transpose(brr)

End With
复制代码
练习二（正则）：
strText = Mid(strText, i) '截取从查找月份以后的网页内容

Dim match, matches, arr(), arow As Integer, acol As Byte

With CreateObject("vbscript.regexp") '正则引用

.Pattern = ">[^<].*?(?=<)" '匹配HTML网页标记（以">"开头且至少一个非"<"的字符，以"<"结尾的内容）

.Global = True '全局匹配

Set matches = .Execute(strText) '匹配结果导出到matches

End With

ReDim arr(1 To 6, 1 To Day(CDate(Format(CLng(strDate) + 1, "0000-00") & "-01") - 1) + 1) '定义一个当月的最后一天+1（列标签+当月天数）为列宽，行高是6的二维数组

acol = 1 '设置数组初始列号

For Each match In matches

arow = arow + 1

If arow > 6 Then '当大于行高6时换行（重置arow=1,且列号递增1）

   If IsDate(Mid(match, 2)) = False Then Exit For '判断matches中每隔6个元素是否为日期格式，不是则跳出循环

   arow = 1

   acol = acol + 1

End If

arr(arow, acol) = Mid(match, 2)

Next

With Sheets("作业二结果") '清空原区域并导入数组arr到单元格

.UsedRange.ClearContents

.Range("A1") = strFind

.Range("A2").Resize(UBound(arr, 2), UBound(arr)) = Application.Transpose(arr)

End With
复制代码

箫风 · 发表于 2013-11-12 08:26

C05：箫风
Sub DataPacket(rgSource As Range, rgDest As Range, bGroupCount As Byte)
'rgSource:源单元格
'rgdest:写入单元格
'数据分组的行数
'-----------过程的声明不得修改--------------
Dim arr
Dim i As Integer, j As Integer, k As Integer
On Error Resume Next
arr = rgSource
If IsArray(arr) Then
k = UBound(arr) * UBound(arr, 2)
ReDim arr1(1 To k)
ReDim arr2(1 To bGroupCount, 1 To Application.WorksheetFunction.RoundUp(k / bGroupCount, 0))
      '以下双层循环将选定区域数据写入一维数组中
      For i = LBound(arr, 2) To UBound(arr, 2)
         For j = LBound(arr) To UBound(arr)
            arr1((i - 1) * UBound(arr) + j) = arr(j, i)
         Next j
      Next i
      '以下双层循环将前面生成的一维数组中的数据写入新的二维数组中
      For i = LBound(arr2) To UBound(arr2)
         For j = LBound(arr2, 2) To UBound(arr2, 2)
            arr2(i, j) = arr1((i - 1) * UBound(arr2, 2) + j)
         Next j
      Next i
rgDest.Resize(i - 1, j - 1) = arr2
Erase arr
Erase arr1
Erase arr2
Else
rgDest = arr
End If
End Sub

Sub 查询天气()

Dim strDate$
Dim strUrl$
Dim strText$
Dim strFind$
Dim i As Long

strUrl = "http://lishi.tianqi.com/wuhan/"
'查询的网址

strDate = Application.InputBox("请输入要查询的年月格式为YYYYMM" & vbCr & vbCr & "例如：201102" & vbCr & vbCr, , Format(DateAdd("m", -1, Now), "yyyymm"), , , , , 2)
'查询的年月，输入格式为YYYYMM

Dim httpRequest As Object
Set httpRequest = CreateObject("Msxml2.XMLHTTP.3.0")
'创建XMLHTTP对象，获取网页数据
'网页数据存储在变量 strText 中
With httpRequest
      .Open "GET", strUrl & strDate & ".html", False
      .send
      strText = .responseText
End With

strFind = "武汉" & Left(strDate, 4) & "年" & Val(Right(strDate, 2)) & "月份天气详情"
'检测输入的日期是否合格
i = InStr(strText, strFind)
If i = 0 Then
      MsgBox "查询月份不对"
      Exit Sub
End If

'-------------------------代码需完成部分---------------------------
'上面的代码和声明部分不得修改
'代码完成部分所需要的变量声明均写在此行下方即可，方便学委评分
Sheets("作业二结果").Cells.ClearContents
Dim arr1() As String, arr2() As String, arr3()
Dim j As Integer
'以下通过三重SPLIT函数的使用截取网页源数据中所需要的部分
arr1 = Split(Split(Split(strText, "<ul class=""t1"">")(1), "</div>")(0), "</li>")
'对截取的源数据进行处理
ReDim arr2(UBound(arr1) - 1)
For i = LBound(arr1) To UBound(arr1) - 1
   If i > 0 And i Mod 6 = 0 Then
      arr2(i) = VBA.Left(Split(arr1(i), ">")(4), 10)
   Else
      arr2(i) = Split(arr1(i), ">")(1)
   End If
Next i
'将源数据一维数组转换成所需要的二维数组
ReDim arr3(1 To (UBound(arr2) + 1) / 6, 1 To 6)
For i = LBound(arr3) To UBound(arr3)
      For j = LBound(arr3, 2) To UBound(arr3, 2)
         arr3(i, j) = arr2((i - 1) * UBound(arr3, 2) + j - 1)
      Next j
Next i
'将表题及存放结果的二维数组写入目标工作表相应区域
Sheets("作业二结果").Range("A1") = strFind
Sheets("作业二结果").Range("A2").Resize(i - 1, j - 1) = arr3
'------------------------------------------------------------------
MsgBox "提取完成"
End Sub

hoogle · 发表于 2013-11-12 09:10

本帖最后由 hoogle 于 2013-11-12 09:14 编辑

C09:hoogle
第一题：

Sub DataPacket(rgSource As Range, rgDest As Range, bGroupCount As Byte)
'rgSource:源单元格
'rgdest:写入单元格
'数据分组的行数
'-----------过程的声明不得修改--------------
On Error GoTo handle
Dim temp, i, j, T, m, n, arrRes()
n = bGroupCount
temp = rgSource.Areas(1).Value
If Not IsArray(temp) Then
rgDest = temp
Exit Sub
ElseIf UBound(temp) Then
T = UBound(temp, 2)
End If
If rgSource.Areas(1).Count < bGroupCount Then n = rgSource.Areas(1).Count
m = Application.RoundUp(rgSource.Areas(1).Count / n, 0)
ReDim arrRes(1 To n, 1 To m)
m = 1: n = 0
For i = 1 To UBound(temp)
For j = 1 To T
If n < UBound(arrRes, 2) Then
n = n + 1
arrRes(m, n) = temp(i, j)
Else
m = m + 1: n = 1
arrRes(m, n) = temp(i, j)
End If
Next
Next
rgDest.Resize(UBound(arrRes), UBound(arrRes, 2)) = arrRes
handle:
T = 1
Resume Next
End Sub

复制代码

第二题：

Sub 查询天气()
Dim strDate$
Dim strUrl$
Dim strText$
Dim strFind$
Dim i As Long
strUrl = "http://lishi.tianqi.com/wuhan/"
'查询的网址
strDate = Application.InputBox("请输入要查询的年月格式为YYYYMM" & vbCr & vbCr & _
"例如：201102" & vbCr & vbCr, , Format(DateAdd("m", -1, Now), "yyyymm"), , , , _
, 2)
'查询的年月，输入格式为YYYYMM
Dim httpRequest As Object
Set httpRequest = CreateObject("Msxml2.XMLHTTP.3.0")
'创建XMLHTTP对象，获取网页数据
'网页数据存储在变量 strText 中
With httpRequest
.Open "GET", strUrl & strDate & ".html", False
.send
strText = .responseText
End With
strFind = "武汉" & Left(strDate, 4) & "年" & Val(Right(strDate, 2)) & "月份天气详情"
'检测输入的日期是否合格
i = InStr(strText, strFind)
If i = 0 Then
MsgBox "查询月份不对"
Exit Sub
End If
'-------------------------代码需完成部分---------------------------
'上面的代码和声明部分不得修改
'代码完成部分所需要的变量声明均写在此行下方即可，方便学委评分
Dim arrData, arrRes(1 To 33, 1 To 6), temp, j, m, temp2 '定义了一些变量
m = 1 '初赋值
arrRes(1, 1) = strFind '这个是输出结果的第一行，也是初赋值
arrData = Split(strText, "<ul>") 'split 把网页分数据成数组
For i = 0 To UBound(arrData) '循环
If InStr(arrData(i), "<div class=""tqtongji2"">") > 0 Then '判断
temp2 = Split(arrData(i), "<li>") '数据放入临时数组
m = m + 1 '这里是结果的表头数据
arrRes(m, 1) = Split(temp2(10), "<")(0) '写到结果数组
arrRes(m, 2) = Split(temp2(11), "<")(0) '同上
arrRes(m, 3) = Split(temp2(12), "<")(0) '同上
arrRes(m, 4) = Split(temp2(13), "<")(0) '同上
arrRes(m, 5) = Split(temp2(14), "<")(0) '同上
arrRes(m, 6) = Split(temp2(15), "<")(0) '同上
End If '结束判断
If InStr(arrData(i), "级") > 0 And InStr(arrData(i), "风") Then '判断是否为所需的数据行
m = m + 1 '写下一行数据
temp = Split(arrData(i), "<") '分割
arrRes(m, 1) = Split(temp(2), ">")(1) '写到结果数组
arrRes(m, 2) = Split(temp(5), ">")(1) '同上
arrRes(m, 3) = Split(temp(7), ">")(1) '同上
arrRes(m, 4) = Split(temp(9), ">")(1) '同上
arrRes(m, 5) = Split(temp(11), ">")(1) '同上
arrRes(m, 6) = Split(temp(13), ">")(1) '同上
End If '结束判断
Next '结束循环
Sheet4.Range("a1").Resize(33, 6) = arrRes '往工作表里赋值
Sheet4.Columns("A:A").NumberFormatLocal = "yyyy/m/d;@" '设置下日期数据的格式
'------------------------------------------------------------------
MsgBox "提取完成"
End Sub

复制代码

雪舞子 · 发表于 2013-11-12 10:13

C06雪舞子交作业

作业一

Sub 按钮1_Click()
Dim rgSource As Range
Dim rgDest As Range
Dim bGroupCount
On Error Resume Next
Set rgSource = Application.InputBox("请选择需要分组的单元格区域", "选择", Type:=8)
'通过对话框选择要分组的单元格区域
If rgSource Is Nothing Then
MsgBox "没有选择要分组的单元格区域"
Exit Sub
End If
Set rgDest = Application.InputBox("请选择分组数据写入的位置", "选择", Type:=8)
'通过对话框选择分组后的数据需写入的单元格
If rgDest Is Nothing Then
MsgBox "没有选择要分组的单元格区域"
Exit Sub
End If
bGroupCount = Application.InputBox("请输入要分成的行数(>=1)", "选择", Default:=2, Type:=2)
'通过对话框输入数据要分成的行数
If Val(bGroupCount) < 1 Then
'检测行数的合法性
MsgBox prompt:="输入的行数不对" & String(2, vbCrLf) & "没有点击确定", Title:="亲，出错了"
Exit Sub
End If
Call DataPacket(rgSource, rgDest, Val(bGroupCount))
'调用分组过程
End Sub
Sub DataPacket(rgSource As Range, rgDest As Range, bGroupCount As Byte)
'rgSource:源单元格
'rgdest:写入单元格
'数据分组的行数
'-----------过程的声明不得修改--------------
Dim arr, brr(), ar, h%, k%, cl%, rw%, i%, j%
If rgSource.Count = 1 Then rgDest = rgSource.Value: Exit Sub '处理单个格格
arr = rgSource '建立源数组
k = UBound(arr) * UBound(arr, 2)
h = Val(bGroupCount)
cl = Int(k / h) - (k / h > Int(k / h)) '计算目标数组列
rw = Int(k / cl) - (k / cl > Int(k / cl)) '计算目标数组行
ReDim brr(1 To rw, 1 To cl) '重新定义目标数组
i = 1
For Each ar In arr
j = j + 1
brr(i, j) = ar '源值赋目标数组
If j = cl Then j = 0: i = i + 1
Next
rgDest.Resize(rw, cl) = brr '写入单元格
End Sub

复制代码

作业二

Sub 查询天气()
Dim strDate$
Dim strUrl$
Dim strText$
Dim strFind$
Dim i As Long
strUrl = "http://lishi.tianqi.com/wuhan/"
'查询的网址
strDate = Application.InputBox("请输入要查询的年月格式为YYYYMM" & vbCr & vbCr & "例如：201102" & vbCr & vbCr, , Format(DateAdd("m", -1, Now), "yyyymm"), , , , , 2)
'查询的年月，输入格式为YYYYMM
Dim httpRequest As Object
Set httpRequest = CreateObject("Msxml2.XMLHTTP.3.0")
'创建XMLHTTP对象，获取网页数据
'网页数据存储在变量 strText 中
With httpRequest
.Open "GET", strUrl & strDate & ".html", False
.send
strText = .responseText
End With
strFind = "武汉" & Left(strDate, 4) & "年" & Val(Right(strDate, 2)) & "月份天气详情"
'检测输入的日期是否合格
i = InStr(strText, strFind)
If i = 0 Then
MsgBox "查询月份不对"
Exit Sub
End If
'-------------------------代码需完成部分---------------------------
'上面的代码和声明部分不得修改
'代码完成部分所需要的变量声明均写在此行下方即可，方便学委评分
Dim brr(1 To 32, 1 To 6), strfx$, reg As Object, mat, m, k%, l%
Set reg = CreateObject("vbscript.regexp") '建立正则法则
strfx = Left(Split(strText, "月份天气详情</h3></div>")(1), InStr(Split(strText, "月份天气详情</h3></div>")(1), "/div>"))
'截取天气数据(以"月份天气详情</h3></div>"分界,截取split第二段开始至"/div>"一段数据)
With reg
.Global = True
.Pattern = "[一-龢\d]+[一-龢-\d+~]*(?=</)" '正则表达式
k = 1
Set mat = .Execute(strfx) '符合正则表达式的值全部赋给mat
For Each m In mat '分别取出mat值赋给m
l = l + 1
brr(k, l) = m '天气数据赋给结果数组(32行6列)
If l = 6 Then l = 0: k = k + 1
Next
Sheet4.[a2].CurrentRegion.ClearContents
Sheet4.[a1] = strFind '写标题
Sheet4.[a2].Resize(32, 6) = brr '数组数据写入工作表
End With
'------------------------------------------------------------------
MsgBox "提取完成"
End Sub

复制代码

Sub 查询天气()
Dim strDate$
Dim strUrl$
Dim strText$
Dim strFind$
Dim i As Long
strUrl = "http://lishi.tianqi.com/wuhan/"
'查询的网址
strDate = Application.InputBox("请输入要查询的年月格式为YYYYMM" & vbCr & vbCr & "例如：201102" & vbCr & vbCr, , Format(DateAdd("m", -1, Now), "yyyymm"), , , , , 2)
'查询的年月，输入格式为YYYYMM
Dim httpRequest As Object
Set httpRequest = CreateObject("Msxml2.XMLHTTP.3.0")
'创建XMLHTTP对象，获取网页数据
'网页数据存储在变量 strText 中
With httpRequest
.Open "GET", strUrl & strDate & ".html", False
.send
strText = .responseText
End With
strFind = "武汉" & Left(strDate, 4) & "年" & Val(Right(strDate, 2)) & "月份天气详情"
'检测输入的日期是否合格
i = InStr(strText, strFind)
If i = 0 Then
MsgBox "查询月份不对"
Exit Sub
End If
'-------------------------代码需完成部分---------------------------
'上面的代码和声明部分不得修改
'代码完成部分所需要的变量声明均写在此行下方即可，方便学委评分
Dim arr, crr, brr(0 To 31, 0 To 5), strfx$, m%, k%, l%
strfx = Left(Split(strText, "月份天气详情</h3></div>")(1), InStr(Split(strText, "月份天气详情</h3></div>")(1), "/div>"))
'截取天气数据(以"月份天气详情</h3></div>"分界,截取split第二段开始至"/div>"一段数据)
arr = Split(strfx, "</ul>")
'按天数据分段
For k = 0 To UBound(arr) - 1
crr = Split(arr(k), "</li>")
'天气类别数据分段
For l = 0 To UBound(crr) - 1
m = InStr(crr(l), "<li>")
'提取数据
If l = 0 And Right(crr(l), 1) = ">" Then m = Len(crr(l)) - 17
'日期数据处理
brr(k, l) = Mid(crr(l), m + 4, 10)
'提取后的天气数据存入数组 brr()
Next
Next
Sheet4.[a2].CurrentRegion.ClearContents
Sheet4.[a1] = strFind '写标题
Sheet4.[a2].Resize(32, 6) = brr '数组数据写入工作表
'------------------------------------------------------------------
MsgBox "提取完成"
End Sub

复制代码

hrpotter · 发表于 2013-11-12 19:37

C03:hrpotter

Option Explicit
Sub 按钮1_Click()
Dim rgSource As Range
Dim rgDest As Range
Dim bGroupCount, brr
On Error Resume Next
Set rgSource = Application.InputBox("请选择需要分组的单元格区域", "选择", Type:=8)
'通过对话框选择要分组的单元格区域
If rgSource Is Nothing Then
MsgBox "没有选择要分组的单元格区域"
Exit Sub
End If
Set rgDest = Application.InputBox("请选择分组数据写入的位置", "选择", Type:=8)
'通过对话框选择分组后的数据需写入的单元格
If rgDest Is Nothing Then
MsgBox "没有选择要分组的单元格区域"
Exit Sub
End If
bGroupCount = Application.InputBox("请输入要分成的行数(>=1)", "选择", Default:=2, Type:=2)
'通过对话框输入数据要分成的行数
If Val(bGroupCount) < 1 Then
'检测行数的合法性
MsgBox prompt:="输入的行数不对" & String(2, vbCrLf) & "没有点击确定", Title:="亲，出错了"
Exit Sub
End If
Call DataPacket(rgSource, rgDest, Val(bGroupCount))
'调用分组过程
End Sub
Sub DataPacket(rgSource As Range, rgDest As Range, bGroupCount As Byte)
'rgSource:源单元格
'rgdest:写入单元格
'数据分组的行数
'-----------过程的声明不得修改--------------
Dim arr(), rng As Range, rg As Range '定义变量
Dim i As Long, j As Long, k As Long
Set rng = Range(Split(rgSource.Address, ",")(0)) '当选择的单元格是多重区域时，只考虑第一个区域分组。
If rng.Count = 1 Then '如果选择的单元格为单个单元格时
rgDest = rng.Value '写入单元格直接等于源单元格
Exit Sub '跳出过程
End If
i = -Int(-rng.Count / bGroupCount) '计算分行所需的列数
ReDim arr(1 To bGroupCount, 1 To i) '重新定义结果数组
For Each rg In rng '将源单元格数据依次写入结果数组
i = Int(k / UBound(arr, 2)) + 1
j = k Mod UBound(arr, 2) + 1
arr(i, j) = rg.Value
k = k + 1
Next
rgDest.Resize(UBound(arr), UBound(arr, 2)) = arr '将结果数组写入要求位置
End Sub
Sub 查询天气()
Dim strDate$
Dim strUrl$
Dim strText$
Dim strFind$
Dim i As Long
strUrl = "http://lishi.tianqi.com/wuhan/"
'查询的网址
strDate = Application.InputBox("请输入要查询的年月格式为YYYYMM" & vbCr & vbCr & "例如：201102" & vbCr & vbCr, , Format(DateAdd("m", -1, Now), "yyyymm"), , , , , 2)
'查询的年月，输入格式为YYYYMM
Dim httpRequest As Object
Set httpRequest = CreateObject("Msxml2.XMLHTTP.3.0")
'创建XMLHTTP对象，获取网页数据
'网页数据存储在变量 strText 中
With httpRequest
.Open "GET", strUrl & strDate & ".html", False
.send
strText = .responseText
End With
strFind = "武汉" & Left(strDate, 4) & "年" & Val(Right(strDate, 2)) & "月份天气详情"
'检测输入的日期是否合格
i = InStr(strText, strFind)
If i = 0 Then
MsgBox "查询月份不对"
Exit Sub
End If
'-------------------------代码需完成部分---------------------------
'上面的代码和声明部分不得修改
'代码完成部分所需要的变量声明均写在此行下方即可，方便学委评分
Dim str As String, arr, brr, crr(), j As Long '定义变量
str = Split(strText, "tqtongji2")(1)
str = Left(str, InStr(str, "</div>") - 1) '取出天气详情表格所在的文本串
arr = Split(str, "</ul>") '将天气详情表格每行数据分割放入一维数组中
ReDim crr(1 To UBound(arr), 1 To 6) '重新定义结果数组
crr(1, 1) = "日期" '将标题放入数组
crr(1, 2) = "最高气温"
crr(1, 3) = "最低气温"
crr(1, 4) = "天气"
crr(1, 5) = "风向"
crr(1, 6) = "风力"
For i = 1 To UBound(arr) - 1
brr = Split(arr(i), "<li>")
crr(i + 1, 1) = Mid(brr(1), InStr(brr(1), ">") + 1, 10) '将日期取出放入数组第一列
For j = 2 To 6
crr(i + 1, j) = Left(brr(j), InStr(brr(j), "<") - 1) '将其他相关数据放入数组的二到六列
Next
Next
With Sheet4
.Range("a1:f33").ClearContents '清空结果表原有数据
.Range("a1") = strFind '将结果表标题写入a1单元格
.Range("a2").Resize(UBound(crr), 6) = crr '将结果数组写入
End With
'------------------------------------------------------------------
MsgBox "提取完成"
End Sub

复制代码

cxloen · 发表于 2013-11-13 00:53

先交一题，愧对老师
Dim arr, arr1, strtext1
Dim k, i1
Dim str1, str2
str1 = "武汉" & Left(strDate, 4) & "年" & Val(Right(strDate, 2)) & "月份天气统计"    '设定截取字段 "武汉2013年10月份天气统计"
strtext1 = Mid(strText, i, InStr(strText, str1) - i)    '提取表格字段

strtext1 = Replace(strtext1, Chr(9), "")    '替换提取字符中的空格及表格字符
strtext1 = Replace(strtext1, Chr(10), "")
strtext1 = Replace(strtext1, Chr(13), "")
strtext1 = Replace(strtext1, Chr(32), "")
strtext1 = Replace(strtext1, "</a>", "")
str2 = "</li></ul></div><divstyle=""clear:both""></div></div><divclass=""lishicity03""><script>lishicity_index_03();</script></div><divid=""tianqi_stat""class=""box-basem7""><divclass=""box-hd""><h3class=""box-t-l"">"
strtext1 = Replace(strtext1, str2, "")  '替换提取字段末尾多余字节

arr = Split(strtext1, "</li></ul><ul><li><ahref=""http://wuhan.tianqi.com/")    '将字段拆分成数组
         For i1 = 0 To UBound(arr)                                     '数组ARR循环
            arr1 = Split(arr(i1), "</li><li>")                         '将数组内的元素拆分成日期,最高气温,最低气温,天气,风向,风力
            k = k + 1                                                 '循环将拆分的字段写入表格中
            Sheets("作业二结果").Range("a" & k).Resize(1, 6) = arr1
            Sheets("作业二结果").Range("a" & k) = Right(arr1(0), 10) '将日期字段提取成年-月-日,去除多余字节

         Next
Sheets("作业二结果").Range("a1") = "日期"  '替换第一个数组中的多余字符

sayloveyou2010 · 发表于 2013-11-13 16:27

本帖最后由 sayloveyou2010 于 2013-11-13 16:47 编辑

C01:sayloveyou2010
第一题：

Sub DataPacket(rgSource As Range, rgDest As Range, bGroupCount As Byte)
'rgSource:源单元格
'rgdest:写入单元格
'数据分组的行数
'-----------过程的声明不得修改--------------
Dim arr(), Mycol%, brr(), mm, i% '定义相关变量
If rgSource.Count > 1 Then '如果所选区域不是单个单元格，那么
arr = rgSource.Value '将选区数据装入数组arr
Mycol = Application.RoundUp(UBound(arr, 1) * UBound(arr, 2) / bGroupCount, 0) '根据行求出列数
ReDim brr(1 To bGroupCount, 1 To Mycol) '重新定义结果数组brr
For Each mm In arr '遍历数据源数组Arr
i = i + 1 '计数器
brr(Int((i - 1) / Mycol) + 1, ((i - 1) Mod Mycol) + 1) = mm '将数据源的数据写入结果数组brr
Next mm
rgDest.Resize(UBound(brr), UBound(brr, 2)) = brr '读出brr
Else
rgDest = rgSource '如果所选区域是单个单元格，则直接读出
End If
Erase arr, brr
End Sub

复制代码

第二题：

sub 天气查询()
Dim arr, brr(), crr(), arr1(), x%, y%, y1%, m%, n%, v, Z% '定义相关变量
arr = Split(strText, "<li>风力</li>") '以<li>风力</li>将数据源分成两段
arr = Split(arr(1), "<div style=""clear:both""></div>") '以<div style=""clear:both""></div>切分
arr = Split(arr(0), ".html"">") '以.html"">切分，找到想要的部分
ReDim brr(1 To UBound(arr)) '重新定义数组brr
ReDim arr1(1 To UBound(arr)) '重新定义数组arr1
ReDim crr(1 To UBound(arr), 1 To 5) '重新定义数组crr
For x = 1 To UBound(arr) '循环arr
m = InStr(arr(x), "<") '找到<的位置
brr(x) = Left(arr(x), m - 1) '找到日期
arr1(x) = Split(arr(x), "<li>") '以<li>分列
Next x
For y = 1 To UBound(arr1)
For y1 = 1 To 5
n = InStr(arr1(y)(y1), "<") '找到<的位置
crr(y, y1) = Left(arr1(y)(y1), n - 1) '将结果写入数组crr
Next y1
Next y
With Worksheets("作业二结果")
.Cells.ClearContents '清空
.[A1] = strFind '写标题
.Range("A2:F2") = Array("日期", "最高气温", "最低气温", "天气", "风向", "风力")
.Range("A3").Resize(UBound(brr), 1) = Application.Transpose(brr) '读出日期
.Range("B3").Resize(UBound(crr), UBound(crr, 2)) = crr '读出crr
End With
Erase arr, brr, crr, arr1
'------------------------------------------------------------------
MsgBox "提取完成"
End Sub

复制代码

Sellby · 发表于 2013-11-13 18:11

C10:sellby

Sub DataPacket(rgSource As Range, rgDest As Range, bGroupCount As Byte)
'rgSource:源单元格
'rgdest:写入单元格
'数据分组的行数
'-----------过程的声明不得修改--------------
Dim bGroupCol As Byte, i As Byte, j As Byte, n As Byte
Dim Arr(), rgsArr
Dim a, Bln As Boolean
bGroupCol = (rgSource.Count - 1) \ bGroupCount + 1 '分组的列数
ReDim Arr(1 To bGroupCount, 1 To bGroupCol) '声明一个放入分组数据的数组
'===============
rgsArr = rgSource.Value '获得数据源第一区域的数据
'=====判断获得的数据是否数组
If IsArray(rgsArr) Then
'=====如果是数组，进行遍历
For Each a In rgsArr
'=====对分组数组进行循环，将数据写入分组的数组内
For i = 1 To bGroupCount
For j = 1 To bGroupCol
If IsEmpty(Arr(i, j)) Then
Arr(i, j) = a
Bln = True
Exit For '写入后跳出循环
End If
If Bln Then Exit For
Next j
If Bln Then Exit For
Next i
Bln = False
Next
Else
'====如果不是数组，直接赋值
Arr(1, 1) = rgsArr
End If
'=====写入指定单元格
rgDest.Resize(bGroupCount, bGroupCol) = Arr
End Sub
Sub DataPacket2(rgSource As Range, rgDest As Range, bGroupCount As Byte) '多区域时，全部显示
'rgSource:源单元格
'rgdest:写入单元格
'数据分组的行数
'-----------过程的声明不得修改--------------
Dim bGroupCol As Byte, i As Byte, j As Byte, n As Byte
Dim Arr(), rgsArr
Dim a, Bln As Boolean
bGroupCol = (rgSource.Count - 1) \ bGroupCount + 1 '分组的列数
ReDim Arr(1 To bGroupCount, 1 To bGroupCol) '声明一个放入分组数据的数组
'===============
'对数据源区域进行循环
For n = 1 To rgSource.Areas.Count
rgsArr = rgSource.Areas.item(n) '获得数据源一区域的数据
'=====判断获得的数据是否数组
If IsArray(rgsArr) Then
'=====如果是数组，进行遍历
For Each a In rgsArr
'=====对分组数组进行循环，将数据写入分组的数组内
For i = 1 To bGroupCount
For j = 1 To bGroupCol
If IsEmpty(Arr(i, j)) Then
Arr(i, j) = a
Bln = True
Exit For '写入后跳出循环
End If
If Bln Then Exit For
Next j
If Bln Then Exit For
Next i
Bln = False
Next
Else
'====如果不是数组，直接赋值
Arr(1, 1) = rgsArr
End If
Next n
'=====写入指定单元格
rgDest.Resize(bGroupCount, bGroupCol) = Arr
End Sub
Sub 查询天气()
Dim strDate$
Dim strUrl$
Dim strText$
Dim strFind$
Dim i As Long
strUrl = "http://lishi.tianqi.com/wuhan/"
'查询的网址
strDate = Application.InputBox("请输入要查询的年月格式为YYYYMM" & vbCr & vbCr & "例如：201102" & vbCr & vbCr, , Format(DateAdd("m", -1, Now), "yyyymm"), , , , , 2)
'查询的年月，输入格式为YYYYMM
Dim httpRequest As Object
Set httpRequest = CreateObject("Msxml2.XMLHTTP.3.0")
'创建XMLHTTP对象，获取网页数据
'网页数据存储在变量 strText 中
With httpRequest
.Open "GET", strUrl & strDate & ".html", False
.send
strText = .responseText
End With
strFind = "武汉" & Left(strDate, 4) & "年" & Val(Right(strDate, 2)) & "月份天气详情"
'检测输入的日期是否合格
i = InStr(strText, strFind)
If i = 0 Then
MsgBox "查询月份不对"
Exit Sub
End If
'-------------------------代码需完成部分---------------------------
'上面的代码和声明部分不得修改
'代码完成部分所需要的变量声明均写在此行下方即可，方便学委评分
Dim Arr, Brr, tempArr
Dim dCount As Byte, j&
Arr = Split(strText, "<ul class=" & """t1""" & ">") '将代码第一次分列，得到二个元素的数组
Arr = Split(Arr(1), "</div>", 2) '对第二个元素再进行分列
Arr = Split(Arr(0), """" & ">") '对第一个元素进行分列，得到一组天气的原始数组，其中第一个元素为标题，每天的天气数据
dCount = UBound(Arr)
ReDim Brr(0 To dCount, 0 To 5) '声明一个二维数组，用来放天气数据
For i = 0 To dCount '对天气的原始数据进行循环
tempArr = Split(Arr(i), "<li>") '分列
For j = 0 To 5 '对分列得到的数据进行循环
If i = 0 Then
Brr(0, j) = Split(tempArr(j + 1), "<")(0) '对标题行分列，取第一个元素
Else
Brr(i, j) = Split(tempArr(j), "<")(0) '对气象数据分列，取第一个元素
End If
Next j
Next i
With Sheets("作业二结果")
.Cells.Clear
.Range("a1") = strFind '写入标题
.Range("a2").Resize(dCount + 1, 6) = Brr '写入天气详情
End With
'------------------------------------------------------------------
MsgBox "提取完成"
End Sub

复制代码

笨熊猫 · 发表于 2013-11-13 19:29

以为是明后天交作业，时间赶不及了，弄一点是一点。

		自动登录	找回密码
密码			注册

[通知] 【VBA字典数组201301班】C组-第二讲作业上交处

相关帖子

评分

评分

评分

评分

评分

评分

评分

评分

评分