网页资讯视频图片知道文库贴吧地图采购
进入贴吧全吧搜索
excel吧 关注：280,059贴子：1,534,989
  • 32回复贴，共1页

这种情况能用VBA实现吗？求大神们赐教



如上两幅图，下面是想要的自动处理后的结果，A列数据相等并且B列数据也相等，则把下面的相同行移到最上面相相同行的下面，并删除上移后相同的A列和B列的数据，能用VBA自动实现吗？求知道的大神赐教



Option Explicit
Sub abc()
　Dim a, i, j, k, d, t, m, p
　a = Range("a1:c" & [a1].End(xlDown).Row).Value
　ReDim b(1 To UBound(a), 1 To UBound(a, 2))
　Set d = CreateObject("scripting.dictionary")
　For i = 1 To UBound(a)
　　t = a(i, 1) & "," & a(i, 2)
　　d(t) = d(t) & "," & i
　Next
　For Each i In d.keys
　　t = Split(d(i), ","): p = 0
　　For j = 1 To UBound(t)
　　　m = m + 1
　　　If p = 0 Then
　　　　For k = 1 To UBound(a, 2)
　　　　　b(m, k) = a(t(j), k)
　　　　Next
　　　　p = 1
　　　Else
　　　　b(m, 3) = a(t(j), 3)
　　　End If
　　Next
　Next
　[e1].Resize(UBound(b), UBound(b, 2)) = b
End Sub


你的原始数据可以排序吗？能排序的话可以不用vba


上面的代码给你写了点注释，自己按实际情况去修改吧。
Sub abc()
Dim a, i, j, k, d, t, m, p, l
'//C 改成j即10列，以你实际数据的最后列去修改
a = Range("a1:j" & [a1].End(xlDown).Row).Value
ReDim b(1 To UBound(a), 1 To UBound(a, 2))
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(a)
t = a(i, 1) & "," & a(i, 2)
d(t) = d(t) & "," & i
Next
For Each i In d.keys
t = Split(d(i), ","): p = 0
For j = 1 To UBound(t)
m = m + 1
If p = 0 Then
For k = 1 To UBound(a, 2)
b(m, k) = a(t(j), k)
Next
p = 1
Else
'//在添加一个循环，当有重复值时，从第三列开始写入值到数组里面
For l = 3 To UBound(a, 2)
b(m, l) = a(t(j), l)
Next
End If
Next
Next
'//原位写入
[a1].Resize(UBound(b), UBound(b, 2)) = b
End Sub


Option Explicit
Sub abc()
　Dim a, i, j, k, d, t, m, p
　a = [a1].CurrentRegion.Value
　ReDim b(1 To UBound(a), 1 To UBound(a, 2))
　Set d = CreateObject("scripting.dictionary")
　For i = 1 To UBound(a)
　　t = a(i, 1) & "," & a(i, 2)
　　d(t) = d(t) & "," & i
　Next
　For Each i In d.keys
　　t = Split(d(i), ","): p = 0
　　For j = 1 To UBound(t)
　　　m = m + 1
　　　If p = 0 Then
　　　　For k = 1 To UBound(a, 2)
　　　　　b(m, k) = a(t(j), k)
　　　　Next
　　　　p = 1
　　　Else
　　　　b(m, 3) = a(t(j), 3)
　　　End If
　　Next
　Next
　[a1].Offset(, UBound(a, 2) + 1).Resize(UBound(b), UBound(b, 2)) = b
End Sub


Option Explicit
Sub abc()
　Dim a, i, j, k, d, t, m, p, n
　a = [a1].CurrentRegion.Value
　ReDim b(1 To UBound(a), 1 To UBound(a, 2))
　Set d = CreateObject("scripting.dictionary")
　For i = 1 To UBound(a)
　　t = a(i, 1) & "," & a(i, 2)
　　d(t) = d(t) & "," & i
　Next
　For Each i In d.keys
　　t = Split(d(i), ","): p = 0
　　For j = 1 To UBound(t)
　　　m = m + 1
　　　If p = 0 Then n = 1 Else n = 3
　　　For k = n To UBound(a, 2)
　　　　b(m, k) = a(t(j), k)
　　　Next
　　　p = 1
　　Next
　Next
　[a1].Offset(, UBound(a, 2) + 1).Resize(UBound(b), UBound(b, 2)) = b
End Sub


Option Explicit
Sub abc()
　Dim a, i, j, k, d, t, m, p, n
　a = Sheets("sheet1").[a1].CurrentRegion.Value
　ReDim b(1 To UBound(a), 1 To UBound(a, 2))
　Set d = CreateObject("scripting.dictionary")
　For i = 1 To UBound(a)
　　t = a(i, 1) & "," & a(i, 2)
　　d(t) = d(t) & "," & i
　Next
　For Each i In d.keys
　　t = Split(d(i), ","): p = 0
　　For j = 1 To UBound(t)
　　　m = m + 1
　　　If p = 0 Then n = 1 Else n = 3
　　　For k = n To UBound(a, 2)
　　　　b(m, k) = a(t(j), k)
　　　Next
　　　p = 1
　　Next
　Next
　Sheets("sheet2").[a1].Resize(UBound(b), UBound(b, 2)) = b
End Sub




扫二维码下载贴吧客户端

下载贴吧APP
看高清直播、视频！
  • 32回复贴，共1页
分享到: