[已解决]如何用vba实现源数据自动合并？？？

ansteelr · 发表于 2017-2-25 18:12

{:1112:}

最佳答案

老司机带带我

2017-2-26 12:39

Sub 数据转化()
Dim d As Object
Dim i&, j&, n&, m&, k, k1, rng As Range, rng1 As Range
Dim arr, brr(), myPath$
Set d = CreateObject("Scripting.Dictionary")
myPath = ThisWorkbook.Path & "\源数据.xls"
Application.ScreenUpdating = False
With GetObject(myPath)
With .Sheets("sheet1")
n = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a1").CurrentRegion
End With
.Close
End With
For i = 1 To n
If Not d.exists(arr(i, 1) & "_" & arr(i, 2)) Then
m = m + 1
d.Add arr(i, 1) & "_" & arr(i, 2), m
ReDim Preserve brr(1 To m)
Set brr(m) = CreateObject("Scripting.Dictionary")
If Not brr(m).exists(arr(i, 3)) Then
brr(m).Add arr(i, 3), arr(i, 4)
Else
brr(m)(arr(i, 3)) = brr(m)(arr(i, 3)) & "、" & arr(i, 4)
End If
Else
If Not brr(d(arr(i, 1) & "_" & arr(i, 2))).exists(arr(i, 3)) Then
brr(d(arr(i, 1) & "_" & arr(i, 2))).Add arr(i, 3), arr(i, 4)
Else
brr(d(arr(i, 1) & "_" & arr(i, 2)))(arr(i, 3)) = brr(d(arr(i, 1) & "_" & arr(i, 2)))(arr(i, 3)) & "、" & arr(i, 4)
End If
End If
Next
m = 1
With Sheet1
.UsedRange.Delete
For Each k In d.keys
.Cells(m, 1).Resize(1, 2) = Split(k, "_")
Set rng = .Cells(m, 1)
Set rng1 = .Cells(m, 2)
For Each k1 In brr(d(k)).keys
.Cells(m, 3) = k1
.Cells(m, 4) = brr(d(k))(k1)
Set rng = Union(.Cells(m, 1), rng)
Set rng1 = Union(.Cells(m, 2), rng1)
m = m + 1
Next
rng.Merge
rng1.Merge
Set rng = Nothing: Set rng1 = Nothing
Next
End With
Application.ScreenUpdating = True
End Sub

复制代码

老司机带带我 · 发表于 2017-2-26 12:39

Sub 数据转化()
Dim d As Object
Dim i&, j&, n&, m&, k, k1, rng As Range, rng1 As Range
Dim arr, brr(), myPath$
Set d = CreateObject("Scripting.Dictionary")
myPath = ThisWorkbook.Path & "\源数据.xls"
Application.ScreenUpdating = False
With GetObject(myPath)
With .Sheets("sheet1")
n = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a1").CurrentRegion
End With
.Close
End With
For i = 1 To n
If Not d.exists(arr(i, 1) & "_" & arr(i, 2)) Then
m = m + 1
d.Add arr(i, 1) & "_" & arr(i, 2), m
ReDim Preserve brr(1 To m)
Set brr(m) = CreateObject("Scripting.Dictionary")
If Not brr(m).exists(arr(i, 3)) Then
brr(m).Add arr(i, 3), arr(i, 4)
Else
brr(m)(arr(i, 3)) = brr(m)(arr(i, 3)) & "、" & arr(i, 4)
End If
Else
If Not brr(d(arr(i, 1) & "_" & arr(i, 2))).exists(arr(i, 3)) Then
brr(d(arr(i, 1) & "_" & arr(i, 2))).Add arr(i, 3), arr(i, 4)
Else
brr(d(arr(i, 1) & "_" & arr(i, 2)))(arr(i, 3)) = brr(d(arr(i, 1) & "_" & arr(i, 2)))(arr(i, 3)) & "、" & arr(i, 4)
End If
End If
Next
m = 1
With Sheet1
.UsedRange.Delete
For Each k In d.keys
.Cells(m, 1).Resize(1, 2) = Split(k, "_")
Set rng = .Cells(m, 1)
Set rng1 = .Cells(m, 2)
For Each k1 In brr(d(k)).keys
.Cells(m, 3) = k1
.Cells(m, 4) = brr(d(k))(k1)
Set rng = Union(.Cells(m, 1), rng)
Set rng1 = Union(.Cells(m, 2), rng1)
m = m + 1
Next
rng.Merge
rng1.Merge
Set rng = Nothing: Set rng1 = Nothing
Next
End With
Application.ScreenUpdating = True
End Sub

复制代码

laoau138 · 发表于 2017-2-26 18:08

老司机带带我发表于 2017-2-26 12:39

用VBA 不用公式不用辅助A列实现跨表提取等距离间隔行数据

http://www.excelpx.com/thread-428061-1-1.html

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