设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 培训班 › Excel VBA字典班 › 【VBA字典数组201301班】B组-第二讲作业上交处
返回列表 发新帖
查看: 2859|回复: 8

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

[复制链接]
发表于 2013-11-12 12:38 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 从从容容 于 2013-11-16 15:55 编辑

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

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

上交作业时，直接贴代码即可，
为方便统计，请在回贴时输入 ID与编号
option, 上交, 统计

相关帖子
回复

使用道具 举报

发表于 2013-11-12 16:20 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 幽月儿 于 2013-11-13 11:58 编辑

B06:幽月儿
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)
'rgSource:源单元格
'rgdest:写入单元格
'数据分组的行数
'-----------过程的声明不得修改--------------
    Dim i As Integer, j As Integer, k As Integer
    Dim arr
    Dim rg As Range
    i = Application.WorksheetFunction.CountA(rgSource)

    If i Mod 2 Then
        i = i / bGroupCount
    Else
        i = (i + 1) / bGroupCount
    End If
    ReDim arr(1 To bGroupCount, 1 To i)
    j = 1: k = 1
    For Each rg In rgSource
        arr(j, k) = rg.Value
        k = k + 1
        If k > i Then
            j = j + 1
            k = 1
        End If
    Next
    rgDest.Resize(bGroupCount, i) = arr
End Sub

Sub 查询天气()

    Dim strDate$
    Dim strUrl$
    Dim strText$
    Dim strFind$
    Dim arr1, arr2, result(1 To 32, 1 To 6)
    Dim i As Long, j As Byte, k As Byte, m As Byte, ii 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

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


    strText = Mid(strText, i)
    i = InStr(Len(strFind) + 20, strText, "</div>")
    strText = Left(strText, i - 1)
    strText = Replace(strText, "<ul class=""t1"">", "<ul>")

    arr1 = Split(strText, "<ul>")
    arr2 = Split(arr1(1), "<li>")
    m = m + 1

    For k = LBound(arr2) + 1 To UBound(arr2)
        result(m, k) = Left(arr2(k), InStr(arr2(k), "<") - 1)
    Next

    For j = LBound(arr1) + 2 To UBound(arr1)
        arr2 = Split(arr1(j), "<li>")
        m = m + 1
        result(m, 1) = Mid(arr2(1), InStr(arr2(1), ">") + 1, 10)
        For k = LBound(arr2) + 2 To UBound(arr2)
            result(m, k) = Left(arr2(k), InStr(arr2(k), "<") - 1)
        Next
    Next
    Application.ScreenUpdating = False

    With Range("a2")
        .CurrentRegion.ClearContents
        .Resize(m, UBound(result, 2)).Value = result
        .CurrentRegion.EntireColumn.AutoFit
    End With
    Range("a1").Value = strFind
    Application.ScreenUpdating = true
    '------------------------------------------------------------------
    MsgBox "提取完成"

End Sub

评分

参与人数 1金币 +20 收起 理由
从从容容 + 20 赞一个!

查看全部评分

回复

使用道具 举报

wp8680
发表于 2013-11-12 22:20 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
B09:wp8680
  1. Option Explicit

  3. Sub 按钮1_Click()
  4.     Dim rgSource As Range
  5.     Dim rgDest As Range
  6.     Dim bGroupCount

  8.     On Error Resume Next
  9.     Set rgSource = Application.InputBox("请选择需要分组的单元格区域", "选择", Type:=8)
  10.     '通过对话框选择要分组的单元格区域
  11.     If rgSource Is Nothing Then
  12.         MsgBox "没有选择要分组的单元格区域"
  13.         Exit Sub
  14.     End If

  16.     Set rgDest = Application.InputBox("请选择分组数据写入的位置", "选择", Type:=8)
  17.     '通过对话框选择分组后的数据需写入的单元格
  18.     If rgDest Is Nothing Then
  19.         MsgBox "没有选择要分组的单元格区域"
  20.         Exit Sub
  21.     End If

  23.     bGroupCount = Application.InputBox("请输入要分成的行数(>=1)", "选择", Default:=2, Type:=2)
  24.     '通过对话框输入数据要分成的行数
  25.     If Val(bGroupCount) < 1 Then
  26.         '检测行数的合法性
  27.         MsgBox prompt:="输入的行数不对" & String(2, vbCrLf) & "没有点击确定", Title:="亲，出错了"
  28.         Exit Sub
  29.     End If

  31.     Call DataPacket(rgSource, rgDest, Val(bGroupCount))
  32.     '调用分组过程

  34.     '--------记录操作----------
  35.     With ActiveSheet.Range("c" & Cells.Rows.Count).End(xlUp)
  36.         .Offset(1, 0) = .Value + 1
  37.         .Offset(1, 1) = rgSource.Address(RowAbsolute:=False, columnabsolute:=False)
  38.         .Offset(1, 2) = rgDest.Address(RowAbsolute:=False, columnabsolute:=False)
  39.         .Offset(1, 3) = Val(bGroupCount)
  40.     End With
  41. End Sub

  43. Sub DataPacket(rgSource As Range, rgDest As Range, bGroupCount As Byte)
  44. 'rgSource:源单元格
  45. 'rgdest:写入单元格
  46. '数据分组的行数
  47. '-----------过程的声明不得修改--------------
  48.     Dim rg As Range, x%, m%, n%
  49.     For Each rg In rgSource    '遍历循环取出数据
  50.         m = (x Mod bGroupCount)    '为重新排组的数据进行定义行位置
  51.         n = Int(x / bGroupCount)    '为重新排组的数据进行定义列位置
  52.         rgDest.Offset(m, n).Value = rg.Value    '取出数据放进定义的行列位置上
  53.         x = x + 1    '记录数据个数
  54.     Next rg
  55. End Sub

  57. Sub 查询天气()

  59.     Dim strDate$
  60.     Dim strUrl$
  61.     Dim strText$
  62.     Dim strFind$
  63.     Dim i As Long


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

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

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

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

  90.     '-------------------------代码需完成部分---------------------------
  91.     '上面的代码和声明部分不得修改
  92.     '代码完成部分所需要的变量声明均写在此行下方即可，方便学委评分
  93.     Dim st
  94.     Dim x, m, n, a
  95.     Dim arr, brr()
  96.     x = InStr(strText, "武汉" & Left(strDate, 4) & "年" & Val(Right(strDate, 2)) & "月份天气统计") - i    '查出有用数据的结束位置
  97.     st = Mid(strText, i, x)    '提出有用数据
  98.     arr = Split(st, "<li>")    '对数据进行分列，形成一维数组
  99.     For m = 1 To UBound(arr) Step 6    '对数组进行按固定循环(为下面取出数据到brr中）
  100.         n = n + 1
  101.         ReDim Preserve brr(1 To 6, 1 To n)    '重置结果存放数组的大小
  102.         brr(1, n) = Left(strDate, 4) & "-" & Val(Right(strDate, 2)) & "-" & n - 1    '取巧的方法得到日期
  103.         For a = 2 To 6
  104.             brr(a, n) = Split(arr(m + a - 1), "</li>")(0)    '依次取出再次分列后的数据的第一个值。
  105.         Next a
  106.     Next m
  107.     brr(1, 1) = "日期"    '重赋brr的第一个值为日期

  109.     Sheets("作业二结果").Range("a2").Resize(UBound(brr, 2), 6) = Application.WorksheetFunction.Transpose(brr)    '将数组写入表格
  110.     Sheets("作业二结果").Range("a1") = strFind
  111.     '------------------------------------------------------------------
  112.     MsgBox "提取完成"
  113. End Sub
复制代码

评分

参与人数 1金币 +20 收起 理由
从从容容 + 20 很给力!

查看全部评分

回复

使用道具 举报

zmnyu
发表于 2013-11-12 22:27 | 显示全部楼层
B03-zmnyu交第二课时作业，代码没有优化，可能方法复杂了，只帖了答题部分代码，请老师批阅！

第一题：
  1. '-----------过程的声明不得修改--------------
  2.     Dim arr(), brr(), rg
  3.     Dim k As Byte, i As Byte, j As Byte, x As Byte
  4.     If IsArray(rgSource) Then        '如果选定区域为数组

  6.         arr() = rgSource.Value             '把选定区域的值装入数组arr
  7.         k = Int(UBound(arr) * UBound(arr, 2) / bGroupCount + 0.9)    'k为每行单元格的个数
  8.     Else                                 '否则，（选定区域为一个单元格）
  9.         rgDest.Value = rgSource.Value  '直接把这个单元格值返回到要写入的单元格
  10.         Exit Sub                       '退出程序
  11.     End If
  12.     i = 1    '变量i表示结果数组brr的第一维
  13.     ReDim brr(1 To bGroupCount, 1 To k)    '指定结果数组brr的大小
  14.     For Each rg In arr                      '通过for each 循环把arr的值按照规则逐一装入brr
  15.         If j >= k Then
  16.             j = 1       '变量j表示结果数组brr的第二维
  17.             i = i + 1
  18.         Else
  19.             j = j + 1
  20.         End If
  21.         brr(i, j) = rg
  22.     Next
  23.     rgDest.Resize(UBound(brr), UBound(brr, 2)) = brr  '把结果输出到指定单元格区域
  24.     '-----------答题部分结束--------------
复制代码
第二题：
  1.     '-------------------------代码需完成部分---------------------------
  2.     '上面的代码和声明部分不得修改
  3.     '代码完成部分所需要的变量声明均写在此行下方即可，方便学委评分

  5.     Dim arr, brr()
  6.     Dim k As Integer, k1 As Integer, k2 As Integer
  7.     Dim br As Integer, bc As Integer
  8.     arr = Split(strText, "<li>")      '先用Split对strText里面存的网页源码按"<li>"进行分列，结果装入数组arr
  9.     k1 = 999                           '给变量k1指定一个较大的数值
  10.     For k = 1 To UBound(arr)            '对arr进行循环
  11.         If arr(k) Like "日期*" Then k1 = k   '如果在arr的元素里有开头为“日期”字样的，则把当前的k值记录到k1
  12.         If arr(k) Like "*</div>*" And k > k1 Then
  13.               '如果在arr的元素里有包含“</div>”字样的，且k>k1
  14.             k2 = k  '则把当前的k值记录到k1
  15.             Exit For  '取到k2值后，退出当前循环
  16.         End If
  17.     Next
  18.     ReDim brr(1 To (k2 - k1 + 1) / 6, 1 To 6)  '重新定义数组brr大小
  19.     For br = 1 To UBound(brr)
  20.         For bc = 1 To UBound(brr, 2)
  21.             If Left(arr(k1), 7) = "<a href" Then  '如果arr(k1)的前七位为 "<a href"，证明其为日期列
  22.                 brr(br, bc) = Left(Split(arr(k1), ">")(1), 10)   '提取出日期并赋值给brr(br,bc)
  23.             Else                                                   '否则呢？
  24.                 brr(br, bc) = Left(arr(k1), InStr(arr(k1), "</li>") - 1)
  25.                       '提取arr(k1)的"</li>"以前的部分，并赋值给brr(br,bc)
  26.             End If
  27.             k1 = k1 + 1   '每循环一次，k1自动加一
  28.         Next
  29.     Next
  30.     With Sheets("作业二结果")              '对工作表“作业二结果”批量操作
  31.         .Range("A1:F33").ClearContents     '清除此工作表A1:F33区域内的全部内容
  32.         .Range("A2:A" & UBound(brr) + 1).NumberFormatLocal = "yyyy/m/d"
  33.                '设置存放日期的A列区域单元格格式为短日期型
  34.         .Range("A1") = strFind   '把变量strFind写入到A1单元格，即“武汉****年*月份天气详情”
  35.         .Range("A2").Resize(UBound(brr), UBound(brr, 2)) = brr
  36.                '把brr输出到以A2为左上角的对应大小的单元格区域内
  37.     End With
  38.     '------------------------------------------------------------------
复制代码
再上传附件一个：

B03-zmnyu【VBA字典数组201301班】第二讲作业【代码需完成】.rar (65.4 KB, 下载次数: 7)

评分

参与人数 1金币 +20 收起 理由
从从容容 + 20 赞一个!

查看全部评分

回复

使用道具 举报

发表于 2013-11-13 08:42 | 显示全部楼层
本帖最后由 shanxiren 于 2013-11-13 15:54 编辑

【VBA字典数组201301班】-B07-shanxiren.rar (55.01 KB, 下载次数: 3)

点评

as0810114
直接贴代码。  发表于 2013-11-13 12:54

评分

参与人数 1金币 +20 收起 理由
从从容容 + 20 赞一个!

查看全部评分

回复

使用道具 举报

发表于 2013-11-13 16:40 | 显示全部楼层
B02：望天打卦
先交作业 回头再整

【VBA字典数组201301班】第二讲作业【代码需完成】B02-望天打卦.rar

60.84 KB, 下载次数: 5

点评

从从容容
要求直接贴出代码，不必上传附件。  发表于 2013-11-14 10:40

评分

参与人数 1金币 +10 收起 理由
从从容容 + 10 第二题没有完成

查看全部评分

回复

使用道具 举报

发表于 2013-11-13 16:49 | 显示全部楼层
本帖最后由 雨后彩霞 于 2013-11-13 20:22 编辑

Sub DataPacket(rgSource As Range, rgDest As Range, bGroupCount As Byte)
Dim arr()
Dim brr()
Dim lx, y, rg, k
Set rgSource = Application.InputBox("请选择需要分组的单元格区域", "选择", Type:=8)
If rgSource Is Nothing Then    '如果 rgSource 是 空值 则执行
    MsgBox "没有选择要分组的单元格区域"
   
    Exit Sub
   
End If
arr = rgSource.Value    'arr= rgSource的值
Set rgDest = Application.InputBox("请选择分组数据写入的位置", "选择", Type:=8)
If rgDest Is Nothing Then    '如果 rgDest 是 空值 则执行
    MsgBox "没有选择要分组的单元格区域"    '<消息框>："没有选择要分组的单元格区域"
   
    Exit Sub    '退出子程序
   
   
End If
bGroupCount = Application.InputBox("请输入要分成的行数(>=1)", "选择", Default:=2, Type:=2)
lx = (rgSource.Count + bGroupCount) \ bGroupCount    'lx=( rgSource的计数值+bGroupCount)\bGroupCount
ReDim brr(1 To bGroupCount, 1 To lx)    '重定义变量brr(1到bGroupCount,1到lx)
For Each rg In arr   '设定变量范围为每一个rg位于arr'遍历数据源数组Arr
    k = k + 1  '计数器
   
    brr(Int((k - 1) / lx) + 1, ((k - 1) Mod lx) + 1) = rg    'brr(<取整>((k-1)/lx)+1,((k-1)Modlx)+1)=rg'将数据源里的数据分别写入结果数组brr中
   
Next rg
rgDest.Resize(UBound(brr, 1), UBound(brr, 2)) = brr    ' rgDest的<重调大小>(<数组上限>(brr,1),<数组上限>(brr,2))=brr
End Sub




Sub 查询天气()
Dim strDate$
Dim strUrl$
Dim strText$
Dim strFind$
Dim i As Long, v, k%, t, j%, l%
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("作业二结果").Range("A1:F600").ClearContents    '<工作表>("作业二结果" )的<单元格>区域("A1:F600" )的清除内容

v = Split(strText, "<li>风力</li>")    'v=<分割字符串>(strText,"<li>风力</li>")

v = Split(v(1), "<div style=""clear:both""></div>")    'v=<分割字符串>(v(1),"<div style=""clear:both""></div>")

v = Split(v(0), ".html"">")    'v=<分割字符串>(v(0),".html"">")

Sheets("作业二结果").[A1] = strFind    '<工作表>("作业二结果" )的[A1]=strFind

Sheets("作业二结果").Range("A2:F2") = Split("日期 最高气温 最低气温 天气 风向 风力", " ")    '<工作表>("作业二结果" )的<单元格>区域("A2:F2")=<分割字符串>("日期 最高气温 最低气温 天气 风向 风力"," ")

For i = 1 To UBound(v)    '设定变量范围为i=1到<数组上限>(v)
   
    k = InStr(v(i), "<")    'k=<正向判断字符串出现位置>(v(i),"<")
   
    Sheets("作业二结果").Cells(i + 2, 1) = Left(v(i), k - 1)    '<工作表>("作业二结果" )的<单元格>坐标(i+2,1)=<截取字符串左侧>(v(i),k-1)
   
    t = Split(v(i), "<li>")    't=<分割字符串>(v(i),"<li>")
   
    For j = 1 To UBound(t)    '设定变量范围为j=1到<数组上限>(t)
        
        k = InStr(t(j), "<")    'k=<正向判断字符串出现位置>(t(j),"<")
        Sheets("作业二结果").Cells(i + 2, j + 1) = Left(t(j), k - 1)    '<工作表>("作业二结果" )的<单元格>坐标(i+2,j+1)=<截取字符串左侧>(t(j),k-1)
    Next
Next
'------------------------------------------------------------------
MsgBox "提取完成"
End Sub

评分

参与人数 1金币 +20 收起 理由
从从容容 + 20 第一题有重复

查看全部评分

回复

使用道具 举报

zjyxp
发表于 2013-11-13 18:36 | 显示全部楼层
B05zjyxp上交第二课作业
刚到家先上交第一题 ，请评委老师多关照
  1. Sub DataPacket(rgSource As Range, rgDest As Range, bGroupCount As Byte)
  2. 'rgSource:源单元格
  3. 'rgdest:写入单元格
  4. '数据分组的行数
  5. '-----------过程的声明不得修改--------------
  6.     Dim arr, brr, crr
  7.     Dim n As Integer, m As Integer, k As Integer '声明相关变量
  8.     arr = rgSource.Value '将指定数据读入arr
  9.     ReDim brr(1 To UBound(arr) * UBound(arr, 2), 1 To 1) '重置brr
  10.     For n = 1 To UBound(arr)
  11.         For m = 1 To UBound(arr, 2)
  12.             k = k + 1
  13.             brr(k, 1) = arr(n, m) '将arr数组读入brr
  14.         Next m
  15.     Next n
  16.         k = 0
  17.         ReDim crr(1 To bGroupCount, 1 To (UBound(arr, 2) * UBound(arr)) / bGroupCount) '重置crr
  18.     For m = 1 To (UBound(arr, 2) * UBound(arr)) / bGroupCount
  19.         For n = 1 To bGroupCount
  20.             k = k + 1
  21.             If k > UBound(arr, 2) * UBound(arr) Then Exit For
  22.                 crr(n, m) = brr(k, 1) '将brr数组读入crr
  23.         Next n
  24.     Next m
  25.         rgDest.Resize(UBound(crr), UBound(crr, 2)) = crr '将crr数组读入指定单元格
  26. End Sub
复制代码

评分

参与人数 1金币 +10 收起 理由
从从容容 + 10 还要加油

查看全部评分

回复

使用道具 举报

发表于 2013-11-13 20:52 | 显示全部楼层
【VBA字典数组201301班】B08 缔造者
  1. Option Explicit

  3. Sub 按钮1_Click()
  4.     Dim rgSource As Range
  5.     Dim rgDest As Range
  6.     Dim bGroupCount

  8.     On Error Resume Next
  9.     Set rgSource = Application.InputBox("请选择需要分组的单元格区域", "选择", Type:=8)
  10.     '通过对话框选择要分组的单元格区域
  11.     If rgSource Is Nothing Then
  12.         MsgBox "没有选择要分组的单元格区域"
  13.         Exit Sub
  14.     End If


  17.     Set rgDest = Application.InputBox("请选择分组数据写入的位置", "选择", Type:=8)
  18.     '通过对话框选择分组后的数据需写入的单元格
  19.     If rgDest Is Nothing Then
  20.         MsgBox "没有选择要分组的单元格区域"
  21.         Exit Sub
  22.     End If

  24.     bGroupCount = Application.InputBox("请输入要分成的行数(>=1)", "选择", Default:=2, Type:=2)
  25.     '通过对话框输入数据要分成的行数
  26.     If Val(bGroupCount) < 1 Then
  27.         '检测行数的合法性
  28.         MsgBox prompt:="输入的行数不对" & String(2, vbCrLf) & "没有点击确定", Title:="亲，出错了"
  29.         Exit Sub
  30.     End If

  32.     Call DataPacket(rgSource, rgDest, Val(bGroupCount))
  33.     '调用分组过程
  34. End Sub

  36. Sub DataPacket(rgSource As Range, rgDest As Range, bGroupCount As Byte)
  37. 'rgSource:源单元格
  38. 'rgdest:写入单元格
  39. '数据分组的行数
  40. '-----------过程的声明不得修改--------------
  41.     Dim arr, brr
  42.     Dim r
  43.     Dim m As Integer
  44.     Dim i As Integer, j As Integer, icolumn As Integer
  45.    
  46.     m = 1
  47.    
  48.     If rgSource.Areas.Count > 1 Then '如果选取的区域是多重区域时
  49.         brr = rgSource.Areas(1) '将第一个区域赋值给变量brr
  50.         icolumn = WorksheetFunction.RoundUp(rgSource.Areas(1).Count / bGroupCount, 0) '计算数据分组时应占列数
  51.     Else
  52.         brr = rgSource '选取的区域赋值给变量brr
  53.         icolumn = WorksheetFunction.RoundUp(rgSource.Count / bGroupCount, 0) '计算数据分组时应占列数
  54.     End If
  55.    
  56.     ReDim arr(1 To bGroupCount, 1 To icolumn) '重新定义数组的大小
  57.    
  58.     If rgSource.Count > 1 Or rgSource.Areas(1).Count > 1 Then '如果选取区域的单元格数大于1或者是多重区域时
  59.         
  60.         For Each r In brr '遍历数组brr
  61.         
  62.             j = j + 1 '计数器
  63.             i = m '计数器
  64.             
  65.             If j <= icolumn Then '如果变量j的值小于或等于应占的列数时
  66.                 arr(i, j) = r '给数组赋值
  67.             Else
  68.                 j = 1 '重新计数
  69.                 m = m + 1 '重新计数
  70.                 arr(m, j) = r '给数组赋值
  71.             End If '结束判断
  72.             
  73.         Next r '循环下一个
  74.         
  75.     End If '结束判断
  76.    
  77.     rgDest.Resize(bGroupCount, icolumn).ClearContents '清除结果区域里的内容
  78.    
  79.     If rgSource.Count = 1 Or rgSource.Areas(1).Count = 1 Then '如果选择了一个单元格或者多重区域的第一个区域是单个单元格时
  80.         rgDest = rgSource.Value '写入单元格的值等于选定的单元格的值
  81.     Else '否则
  82.         rgDest.Resize(bGroupCount, icolumn) = arr '将数组arr赋值给写入单元格区域
  83.     End If '结束判断
  84.    
  85. End Sub
复制代码
第二题不会做。

评分

参与人数 1金币 +10 收起 理由
从从容容 + 10 继续努力

查看全部评分

回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-5-4 12:49 , Processed in 0.354352 second(s), 23 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表