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

sliang28

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

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

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

风林火山

D004-风林火山交作业，老师辛苦了

fffox

交作业，第一题附加没做，没有思路
D09-fffox
第一题

1. Sub DataPacket(rgSource As Range, rgDest As Range, bGroupCount As Byte)
   
2. 'rgSource:源单元格
   
3. 'rgdest:写入单元格
   
4. '数据分组的行数
   
5. '-----------过程的声明不得修改--------------
   
6.     Dim arr, bCol As Byte, i As Byte, j As Byte
   
7.     Dim ar, brr()
   
8.     If rgSource.Count = 1 Then rgDest = rgSource.Value  '如果源单元格区域只有一个单元格，则直接把值放入目标区域
   
9.     If rgSource.Areas.Count = 1 Then                    '如果要源单元格的区域只有一个
   
10.         arr = rgSource.Value                            '单元格区域的值放入数组arr
    
11.         If rgSource.Count Mod bGroupCount = 0 Then      '如果单元格区域个数能被行数整除
    
12.             bCol = rgSource.Count \ bGroupCount         '取得目标区域的列数
    
13.         Else
    
14.             bCol = rgSource.Count \ bGroupCount + 1
    
15.         End If
    
16.     Else                                                '如果要分组的单元格区域多于一个
    
17.         With rgSource.Areas.item(1)                     '取第一个区域
    
18.             arr = .Value                                '把第一个区域的值放入数组arr
    
19.             If .Count Mod bGroupCount = 0 Then          '计算目标区域的列数
    
20.                 bCol = .Count \ bGroupCount
    
21.             Else
    
22.                 bCol = .Count \ bGroupCount + 1
    
23.             End If
    
24.         End With
    
25.     End If
    
26.     ReDim brr(1 To bGroupCount, 1 To bCol)              '声明目标数组
    
27.     i = 1: j = 1                                        '目标数组行列赋初始值
    
28.     For Each ar In arr          '变量ar在arr数组中循环
    
29.         If j = bCol Then        '如果j达到列数
    
30.             brr(i, j) = ar
    
31.             i = i + 1           '行增加1，列变为1
    
32.             j = 1
    
33.         Else
    
34.             brr(i, j) = ar
    
35.             j = j + 1           '否则赋值后列增加1
    
36.         End If
    
37.     Next
    
38.     rgDest.Resize(bGroupCount, bCol).ClearContents      '清除目标区域数据
    
39.     rgDest.Resize(bGroupCount, bCol) = brr              '目标数组brr写入目标区域
    
40. End Sub
    

复制代码

上段代码还有点问题，当选择区域是多个且第一个选择区域只有一个单元格时出错。
修改一下后没问题了

1.     Dim arr, bCol As Byte, i As Byte, j As Byte
   
2.     Dim ar, brr(), arrCount As Integer
   
3.     arr = Range(Split(rgSource.Address, ",")(0))
   
4.     If IsArray(arr) Then
   
5.         arrCount = UBound(arr, 1) * UBound(arr, 2)
   
6.         If arrCount Mod bGroupCount Then
   
7.             bCol = arrCount \ bGroupCount + 1
   
8.         Else
   
9.             bCol = arrCount \ bGroupCount
   
10.         End If
    
11.         ReDim brr(1 To bGroupCount, 1 To bCol)              '声明目标数组
    
12.         i = 1: j = 1                                        '目标数组行列赋初始值
    
13.         For Each ar In arr          '变量ar在arr数组中循环
    
14.             If j = bCol Then        '如果j达到列数
    
15.                 brr(i, j) = ar
    
16.                 i = i + 1           '行增加1，列变为1
    
17.                 j = 1
    
18.             Else
    
19.                 brr(i, j) = ar
    
20.                 j = j + 1           '否则赋值后列增加1
    
21.             End If
    
22.         Next
    
23.         rgDest.CurrentRegion.ClearContents
    
24.         rgDest.Resize(bGroupCount, bCol) = brr
    
25.     Else
    
26.         rgDest = arr
    
27.     End If
    

复制代码

第二题

1.     Dim arr(), brr      '声明arr为结果数组，brr为中间数组
   
2.     Dim x As Integer, y As Integer
   
3.     Dim tqStart As Byte, tqEnd As Integer
   
4.         
   
5.         '查看网页源代码发现，目标数据由<li>和</li>包括，先以<li>分割strText存到brr
   
6.     brr = Split(strText, "<li>")
   
7.    
   
8.     For i = 1 To UBound(brr)                    '在中间数组内循环，brr(0)不包含目标数据，可跳过
   
9.         brr(i) = Split(brr(i), "</li>")(0)      '继续分割，并取第一个字段存回brr(i)
   
10.         If InStr(brr(i), "日期") Then tqStart = i '如果内容是"日期"，就标定开始行
    
11.         If InStr(brr(i), "天）") Then           '如果找到"天）"
    
12.             tqEnd = i - 1                       '标记为结束行
    
13.             Exit For                            '余下内容与结果无关，退出循环
    
14.         End If
    
15.     Next
    
16.    
    
17.     '目标数据在一维数组brr的tqStart--tqEnd区间内，需把数据写入6列多行的目标数组
    
18.     '重新声明arr数组
    
19.     ReDim arr(1 To (tqEnd - tqStart + 1) \ 6, 1 To 6)
    
20.     x = 1: y = 1                    '赋初值
    
21.    
    
22.     For i = tqStart To tqEnd        '在brr数组中循环
    
23.         If y = 6 Then
    
24.             arr(x, y) = brr(i)      '把brr的值赋给arr数组
    
25.             x = x + 1               '满6列后另起一行
    
26.             y = 1
    
27.         ElseIf y = 1 And InStr(brr(i), ".html") Then
    
28.             '应对201205之后的情况，如果brr(i)包含.html字符串
    
29.             arr(x, y) = Split(Split(brr(i), ">")(1), "</a")(0)
    
30.             y = y + 1                   '对该字符串2次分割后，赋值给arr(x,1)
    
31.         Else
    
32.             arr(x, y) = brr(i)          '无上述情况，直接赋值
    
33.             y = y + 1                   '列加1
    
34.         End If
    
35.     Next
    
36.    
    
37.     With Sheets("作业二结果")
    
38.         .Range("a1").CurrentRegion.ClearContents    '目标区域清空
    
39.         .Range("a1") = strFind
    
40.         .Range("a2").Resize(UBound(arr), 6) = arr   '数组写入目标区域
    
41.     End With
    

复制代码

水上漂123

Sub DataPacket(rgSource As Range, rgDest As Range, bGroupCount As Byte)
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

联乔

【VBA字典数组201301班】第二讲作业【代码需完成】D07 联乔.rar (60.28 KB, 下载次数: 5)

2013-11-13 13:16 上传

点击文件名下载附件

xhrys

作业不会做，第二题勉强做了，不知道对不对，先交卷了，再好好想想

ly258

今天一天才赶完作业，真不容易啊！！

w2001pf

D05:w2001pf
Option Explicit

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)
    Dim i As Long, j As Long, m As Long, n As Long
    Dim arr, arrjg
    'rgSource:源单元格
    'rgdest:写入单元格
    '数据分组的行数
    '-----------过程的声明不得修改--------------
    If Selection.Count > 1 Then
    '先判断选定的单元格区域的个数，个数大于1则把选定的区域装入数组arr中，否则直接把选定的单元格赋值给目标单元格
        arr = rgSource.Areas.item(1)
        If UBound(arr) * UBound(arr, 2) Mod bGroupCount = 0 Then    '计算结果数组的列数
            m = UBound(arr) * UBound(arr, 2) / bGroupCount
        Else
            m = Int(UBound(arr) * UBound(arr, 2) / bGroupCount) + 1
        End If
        ReDim arrjg(1 To bGroupCount, 1 To m)
        '定义一个结果数组，数组的行数为指定的行数
        For i = 1 To UBound(arr)    '在数组arr中循环，结果写入到结果数组中
            For j = 1 To UBound(arr, 2)
                n = n + 1
                arrjg(Int((n - 1) / UBound(arrjg, 2)) + 1, (n - 1) Mod UBound(arrjg, 2) + 1) = arr(i, j)
                '结果数组的行数为(n-1)除以结果数组的列数的商取整后加1，结果数组的列数为(n-1)除以结果数组的列数余数加1
            Next j
        Next i
        Range(rgDest.Address).Resize(UBound(arrjg), UBound(arrjg, 2)) = arrjg
    Else
        Range(rgDest.Address) = rgSource
    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

    '-------------------------代码需完成部分---------------------------
    '上面的代码和声明部分不得修改
    '代码完成部分所需要的变量声明均写在此行下方即可，方便学委评分
    Dim arr, tianshu, arrjg, m

    arr = Split(strText, "<li>") '把网页数据分列成数组
    m = DateValue(Left(strDate, 4) & "/" & Right(strDate, 2) & "/" & "01")
   '把指定年月变成标准的日期格式
    tianshu = Day(DateSerial(Year(m), Month(m) + 1, 0))
    '计算当月的天数
    ReDim arrjg(1 To tianshu + 1, 1 To 6)
    '定义一个数组装入当月的记录
    For i = 10 To (tianshu + 1) * 6 + 9
        If InStr(arr(i), strDate) > 0 Then '判断是否包含日期
            arrjg(Int((i - 10) / 6) + 1, (i - 10) Mod 6 + 1) = Split(Right(arr(i), 33), "</a></li>")(0)
            '结果数组的行数为(i-10)除以结果数组的列数的商取整后加1，结果数组的列数为(i-10)除以结果数组的列数余数加1
        Else
            arrjg(Int((i - 10) / 6) + 1, (i - 10) Mod 6 + 1) = Split(arr(i), "</li>")(0)    '把数组中的"</li>"切掉
        End If
    Next i
    With Sheets("作业二结果") '把结果写入到指定位置中
        .UsedRange = ""
        .Range("A1") = strFind
        .Range("A2").Resize(UBound(arrjg), UBound(arrjg, 2)) = arrjg
    End With
    '------------------------------------------------------------------
    MsgBox "提取完成"
End Sub