大侠~利用VBA如何查找相同数据并按指定格式合并指定列的数据

231693424 · 发表于 2011-9-30 21:07

本帖最后由 231693424 于 2011-9-30 21:43 编辑

利用VBA，如何完成按Sheet2中提供的基站名称在sheet1中查找指定数据并按特定格式合并相关列的数据？

231693424 · 发表于 2011-9-30 23:14

那位大哥帮帮忙嘛~

doitbest · 发表于 2011-10-1 10:15

Public Sub qq()
Dim ar, br(), i, d, n
Set d = CreateObject("scripting.dictionary")
ar = Sheets(1).Range(Sheets(1).[a2], Sheets(1).[ab65536].End(3))
For i = 1 To UBound(ar)
If Not d.exists(ar(i, 9)) Then
d(ar(i, 9)) = ""
n = n + 1
ReDim Preserve br(1 To 6, 1 To n)
br(1, n) = ar(i, 9): br(2, n) = ar(i, 12): br(3, n) = ar(i, 14): br(4, n) = ar(i, 15): br(5, n) = ar(i, 3): br(6, n) = ar(i, 4)
Else
br(3, n) = br(3, n) & "\" & ar(i, 14): br(4, n) = CStr(br(4, n) & "\" & ar(i, 15))
End If
Next i
[a2].Resize(n, 6) = Application.Transpose(br)
End Sub

doitbest · 发表于 2011-10-1 10:16

请参考附件

jinsense · 发表于 2011-10-1 10:36

231693424 发表于 2011-9-30 23:14
那位大哥帮帮忙嘛~

你试试吧

配置检索.rar (16.62 KB, 下载次数: 41)

doitbest · 发表于 2011-10-1 10:47

5楼没有利用数组读入读出，速度显得慢，且要依赖第一列的名称进行查找

mjzxlmg · 发表于 2011-10-1 15:21

本帖最后由 mjzxlmg 于 2011-10-1 16:37 编辑

Sub test()
Application.ScreenUpdating = False
Dim arr, brr(), i&, d As Object, m&
Set d = CreateObject("scripting.dictionary")
arr = Sheets(1).Range(Sheets(1).[a2], Sheets(1).[ab65536].End(3))
drr = Sheets(2).Range("a1:a" & Sheets(2).Range("a" & Rows.Count).End(3).Row)
ReDim brr(1 To UBound(arr), 1 To 6)
For i = 1 To UBound(arr)
If Not d.exists(arr(i, 9)) Then
         m = m + 1
         d(arr(i, 9)) = m
         brr(m, 1) = arr(i, 9)
         brr(m, 2) = arr(i, 12): brr(m, 3) = arr(i, 14): brr(m, 4) = arr(i, 15): brr(m, 5) = arr(i, 3): brr(m, 6) = arr(i, 4)
Else
         brr(d(arr(i, 9)), 3) = brr(d(arr(i, 9)), 3) & "/" & arr(i, 14)
         brr(d(arr(i, 9)), 4) = brr(d(arr(i, 9)), 4) & "｜" & arr(i, 15)
End If
Next i
   Set d = Nothing
ReDim crr(1 To UBound(drr), 1 To UBound(brr, 2))
For j = 2 To UBound(drr)
If drr(j, 1) = brr(j - 1, 1) Then
For k = 2 To UBound(brr, 2)
   crr(j - 1, k - 1) = brr(j - 1, k)
Next
End If
Next
   Sheets(2).Range("b2:f65536") = ""
   Sheets(2).[b2].Resize(UBound(drr) - 1, UBound(brr, 2) - 1) = crr
   Application.ScreenUpdating = True
End Sub

231693424 · 发表于 2011-11-20 15:20

mjzxlmg 发表于 2011-10-1 15:21
Sub test()
Application.ScreenUpdating = False
Dim arr, brr(), i&, d As Object, m&

大哥，存在参数未定义

mjzxlmg · 发表于 2011-11-20 20:40

231693424 发表于 2011-11-20 15:20
大哥，存在参数未定义

配置.rar (22.81 KB, 下载次数: 46)

zhangru2199 · 发表于 2018-7-18 15:18

http://club.excelhome.net/thread-1425612-1-1.html

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

[求助] 大侠~利用VBA如何查找相同数据并按指定格式合并指定列的数据