|
|
楼主 |
发表于 2012-11-1 14:52
|
显示全部楼层
本帖最后由 kuaitv 于 2012-11-1 15:07 编辑
hwc2ycy 发表于 2012-11-1 10:53 
新加了注释。
我改代码出现一个问题，就是表三多出13个数据就运行出错，
Sub 提取数据()
Dim arr '存放源数据的数组
Dim arrRst '结果数组
Dim i&, j&, k& '
Dim dic As Object '字典
Dim sKey$ '存放查找的关键字组合
Dim iPos&
Application.ScreenUpdating = False '禁止屏幕刷新
With Worksheets("数据库")
arr = .Range("a2").CurrentRegion '读取A2所在的区域，定位在A2，按ATRL+A，便是所选的区域
'A2是SHEET3数据区的左上角，如果换了别的数据源，结果不一样的话，就得改成对应的单元格
End With
If arr(1, 1) = "" Then Exit Sub '检测A2是否为空单元格
'检测数据行是否在2行以内，标题要占1行，所以，低于2行的数据不做处理，直接退出
If UBound(arr) < 2 Then Exit Sub
Set dic = CreateObject("scripting.dictionary") '创建字典对象
For i = LBound(arr) + 1 To UBound(arr) '以行方式遍历数组，因为读取数据时，第一行是标题，所以加了1，从第2行开始。
'lbound返回的是数组第一维的下标,ubound返回的是数组第一维的上标（总行数）
sKey = arr(i, 7) & "#" & arr(i, 8) '把D列和E列的数据以#号相连 （年级#班级)
If dic.exists(sKey) Then '检测在字典是否存在对应的关键字
arrRst = dic(sKey) '如果存在，则取出关键字对应的ITEM值（这里取出的是数组）
j = UBound(arrRst, 2) 'j为数组第二维上限（即总行数)
ReDim Preserve arrRst(1 To 142, 1 To j + 1) '数组扩容，二维数组只能扩第二维，即列数可以增加。行数已经固定了。如果明白转置，比较好理解。
For k = LBound(arrRst) To UBound(arrRst)
arrRst(k, j + 1) = arr(i, k) '把一行数据(转置)按列的方式写入新列（扩容后的数据列）
Next
dic(sKey) = arrRst '关键字对应的新数组写回字典
Else
'如果字典中不存在此关键字
ReDim arrRst(1 To 142, 1 To 1) '重新定义一个9行1列的新数组
For k = LBound(arrRst) To UBound(arrRst) '把数组行以列的方式写入新数组
arrRst(k, 1) = arr(i, k)
Next
dic(sKey) = arrRst '数组写入到字典对应的关键字。
End If
Next
sKey = [a6] & "#" & [b6] '把查询关键字用#号边接
If Not dic.exists(sKey) Then '如果在字典里查询不到关键字字，则弹出对话框提示，然后退出程序
MsgBox "请输入正确的班级和姓名"
Exit Sub
End If
arrRst = dic(sKey) '根据关键字取回对应的ITEM（数组）
'工作表1条件查询
If ActiveSheet.Name Like "农户登记簿" Then '根据单击按钮时判断活动工作表是在Sheet1还是Sheet2来运行不同的过程
'两个工作表查询时返回内容的不同，就没有写2个过程了，根据工作表名来区分。
'实际运用时，得根据你的工作名来修改此处。代码一旦写好，不可随意修改工作表名
'如果写两个函数，则工作表名就无所谓了。
iPos = 9 '第一行数据写入到工作表所在的行。11行，10行是标题
arrRst = WorksheetFunction.Transpose(arrRst) '之前写入数组的数据是列方式，现在要转置，变成行方式
For i = 1 To UBound(arrRst) Step 13 '因为一次写入是12行，所以用12为一个步长，这样比较方便
ReDim arr(1 To 13, 1 To 8) '重新定义数组arr,12行4列，如果要移值，则要此处也要根据实际修改
For j = 0 To 142 '数据是从1-12，这里用了一个技巧，2个数组都要循环
'i值指示arrRst数组的行,j指示的是arr的行，arr是1-12,
'而j值是从0到11,所以arr应用时用了j+1指示所在行
If i + j <= UBound(arrRst) Then '行与列的对应关系慢慢看本地吧，就会明白的。
arr(j + 1, 1) = arrRst(i + j, 3) '这里生成12行4列的新数据（要写回表格的）
arr(j + 1, 2) = arrRst(i + j, 10) '2，4，5，9列是什么数据可看sheet3对应的列
arr(j + 1, 3) = arrRst(i + j, 9)
arr(j + 1, 4) = arrRst(i + j, 140)
arr(j + 1, 5) = arrRst(i + j, 1)
arr(j + 1, 6) = arrRst(i + j, 54)
arr(j + 1, 7) = arrRst(i + j, 57)
arr(j + 1, 8) = arrRst(i + j, 142)
End If
Next
Range("a" & iPos).ClearContents '清除要写入表格位置的内容，格式保留
Range("a" & iPos - 1).Resize(, 8) = Array("姓名", "电话", "身份证", "信用等级", "农户编号", "评级日期", "贷款证", "授信金额") 'iPos指示的数据左上角，还有标题行得写入
Range("a" & iPos).Resize(UBound(arr), 8) = arr '把arr数据写入表格12行4列
With Range("a" & iPos).Resize(UBound(arr), 8) '设置数据区的背景色
.Interior.Color = 12632256
End With
iPos = iPos + 24 '下一个数据写入位置距当前的数据位置间隔为22行
Next
End If
'工作表2条件查询
If ActiveSheet.Name Like "会议记录" Then
arrRst = WorksheetFunction.Transpose(arrRst) '行列转置
ReDim arr(1 To UBound(arrRst), 1 To 16) '根据查询到的数据行数，生成新数组，只是只有4列
For i = 1 To UBound(arr)
arr(i, 2) = arrRst(i, 3) '1,2,4,9列内容可见sheet3
arr(i, 3) = arrRst(i, 1)
arr(i, 4) = arrRst(i, 137)
arr(i, 5) = arrRst(i, 140)
arr(i, 6) = arrRst(i, 142)
arr(i, 15) = arrRst(i, 140)
arr(i, 16) = arrRst(i, 142)
Next
If [a10] = "" Then '检测A10是否有内容，如果为空
Range("a10").Resize(UBound(arr), 16) = arr '则直接写入结果
'Range("a10").Resize(UBound(arrst), UBound(arrRst, 2)) = arrRst
Else
Range("a10").CurrentRegion.ClearContents '清除原有内容
Range("b9:f9,o9:p9") = Array("姓名", "农户编号", "得分", "评定等级", "授信金额", "评定等级", "授信金额") '写入新标题
Range("a10").Resize(UBound(arr), 4) = arr '写入数据,这里我没有设置背景色了。
End If
End If
Application.ScreenUpdating = True '打开屏幕刷新
End Sub
|
|
楼主: kuaitv
IP卡
狗仔卡
显身卡
发表于 2012-10-31 17:27
