[已解决]去重提取数据

sanpiao

去重提取数据

最佳答案

月排行榜 / 总排行榜

cutecpu

2021-11-8 19:41

sanpiao 发表于 2021-11-8 17:19
老师您好！请您对代码稍作修改，（按列去重提取数据）

Sub demo()
   Set d1 = CreateObject("Scripting.Dictionary")
   Set d2 = CreateObject("Scripting.Dictionary")
   a = Sheet1.[a3].CurrentRegion
   For x = 1 To UBound(a, 2)
      For y = 1 To UBound(a)
         If a(y, x) = 0 Then Exit For
         d1(a(y, x)) = 1
      Next
      d2(x) = d1.keys: d1.RemoveAll
   Next
   For i = 0 To d2.Count - 1
      [a3].Offset(, i).Resize(UBound(d2.items()(i)) + 1) = _
      Application.Transpose(d2.items()(i))
   Next
End Sub

跳转到最佳答案楼层

cutecpu

祝順心，南無阿彌陀佛！

sanpiao

cutecpu 发表于 2021-11-5 21:07
祝順心，南無阿彌陀佛！

老师您发下代码吧

cutecpu

sanpiao 发表于 2021-11-5 21:45
老师您发下代码吧

Sub demo()
   [a3:f1000].ClearContents
   Set d = CreateObject("Scripting.Dictionary")
   a = Sheet1.Range("a3:b" & Sheet1.[a3].End(4).Row)
   For i = 1 To UBound(a)
      If a(i, 2) <> "" Then d(a(i, 1) & a(i, 2)) = Array(a(i, 1), a(i, 2))
   Next
   [a3].Resize(d.Count, 2) = Application.Rept(d.items, 1)
   d.RemoveAll
   a = Sheet1.Range("c3:f" & Sheet1.[c3].End(4).Row)
   For i = 1 To UBound(a)
      d(a(i, 1) & a(i, 2) * 10 ^ 6 + a(i, 3) * 10 ^ 3 + a(i, 4)) = Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4))
   Next
   [c3].Resize(d.Count, 4) = Application.Rept(d.items, 1)
End Sub

sanpiao

cutecpu 发表于 2021-11-5 21:50
Sub demo()
   [a3:f1000].ClearContents
   Set d = CreateObject("Scripting.Dictionary")

感谢老师

cui26896

Sub 简单连接()
Dim cnn As Object, Rst As Object, SQL$
Dim arr
Set cnn = CreateObject("ADODB.Connection")
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=no;IMEX=1';Data Source=" & ThisWorkbook.FullName
SQL = "select f1 from [sheet1$a3:b] group by f1"
SQL = "select a.f1, b.f2 from (" & SQL & ")a left join [sheet1$a3:b]b on b.f1=a.f1 where b.f2 is not null group by a.f1,b.f2"
Set Rst = cnn.Execute(SQL)
With Sheets("Sheet2")
  .Range("a3").CurrentRegion.ClearContents
  .Range("a3").CopyFromRecordset Rst
  SQL = vbNullString
  SQL = "select f1 from [sheet1$c3:f] where f1 is not null group by f1"
  SQL = "select a.f1,b.f2,b.f3,b.f4 from (" & SQL & ")a left join [sheet1$c3:f]b on b.f1=a.f1 group by a.f1,b.f2,b.f3,b.f4"
  Set Rst = cnn.Execute(SQL)
  .Range("c3").CopyFromRecordset Rst
End With
cnn.Close
Set cnn = Nothing
End Sub

cutecpu

SQL 作法

Sub demo()
   Set cnn = CreateObject("adodb.Connection")
   cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=no;IMEX=1';Data Source=" & ThisWorkbook.FullName
   sql1 = "select f1,f2 from [sheet1$a3:b] where f2 is not null group by f1,f2"
   sql2 = "select f1,f2,f3,f4 from [sheet1$c3:f] where f1 is not null group by f1,f2,f3,f4"
   Set rst1 = cnn.Execute(sql1)
   Set rst2 = cnn.Execute(sql2)
   With Sheets("Sheet2")
      .[a3:f1000].ClearContents
      .[a3].CopyFromRecordset rst1
      .[c3].CopyFromRecordset rst2
   End With
End Sub

cui26896

cutecpu 发表于 2021-11-6 18:42
SQL 作法

Sub demo()

版主也会在别人的基础上改啊？不是很佛系吗？

sanpiao

cutecpu 发表于 2021-11-5 21:50
Sub demo()
   [a3:f1000].ClearContents
   Set d = CreateObject("Scripting.Dictionary")

老师您好！请您对代码稍作修改，（按列去重提取数据）

cutecpu

sanpiao 发表于 2021-11-8 17:19
老师您好！请您对代码稍作修改，（按列去重提取数据）

Sub demo()
   Set d1 = CreateObject("Scripting.Dictionary")
   Set d2 = CreateObject("Scripting.Dictionary")
   a = Sheet1.[a3].CurrentRegion
   For x = 1 To UBound(a, 2)
      For y = 1 To UBound(a)
         If a(y, x) = 0 Then Exit For
         d1(a(y, x)) = 1
      Next
      d2(x) = d1.keys: d1.RemoveAll
   Next
   For i = 0 To d2.Count - 1
      [a3].Offset(, i).Resize(UBound(d2.items()(i)) + 1) = _
      Application.Transpose(d2.items()(i))
   Next
End Sub