万帖成专家之不重复处理

LMY123

1   提取不重复值
2   统计重复次数
3   分类汇总
4   多级联动
5   比对与匹配

LMY123

1. 'http://club.excelhome.net/thread-1145518-2-1.html
   
2. Sub 根据内表A列匹配外表A列_提取外表B列的数据_同夹_多薄_指定表_LEFT_JOIN()
   
3.     Application.ScreenUpdating = False
   
4.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
5.     ActiveSheet.UsedRange.Offset(2, 1).ClearContents
   
6.     For Each 外薄 In Fso.GetFolder(ThisWorkbook.Path).Files
   
7.         If 外薄.Name Like "*.xls" And 外薄.Name <> ThisWorkbook.Name Then
   
8.             计数器 = 计数器 + 1
   
9.             If 计数器 = 1 Then
   
10.                 Set 连接 = CreateObject("adodb.connection")
    
11.                 连接.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;hdr=no';Data Source=" & 外薄
    
12.                 SQL = "select b.f2 from [Excel 8.0;hdr=no;Database=" & ThisWorkbook.FullName & ";].[" & ActiveSheet.Name & "$a4:a" & [a65536].End(xlUp).Row & "] a left join [清算表$a3:b] b on a.f1=b.f1"
    
13.             Else
    
14.                 SQL = "select b.f2 from [Excel 8.0;hdr=no;Database=" & ThisWorkbook.FullName & ";].[" & ActiveSheet.Name & "$a4:a" & [a65536].End(xlUp).Row & "] a left join [Excel 8.0;hdr=no;Database=" & 外薄 & ";].[清算表$a3:b] b on a.f1=b.f1"
    
15.             End If
    
16.             Cells(4, 计数器 + 1).CopyFromRecordset 连接.Execute(SQL)
    
17.             Cells(3, 计数器 + 1) = Replace(外薄.Name, ".xls", "")
    
18.         End If
    
19.     Next 外薄
    
20.     Set Fso = Nothing
    
21.     连接.Close
    
22.     Set 连接 = Nothing
    
23.     Application.ScreenUpdating = True
    
24. End Sub

复制代码

LMY123

1. 'http://club.excelhome.net/thread-1195938-1-1.html
   
2. Sub 同夹多薄多表_AB列双条件分类_C列汇总_ADO加字典法()
   
3.     Dim 结果数组(1 To 65530, 0 To 2)
   
4.     Set 字典 = CreateObject("scripting.dictionary")
   
5.     路径 = ThisWorkbook.Path & "": 外薄 = Dir(路径 & "*.xls")
   
6.     Do While 外薄 <> ""
   
7.         If InStr(外薄, ThisWorkbook.Name) = 0 Then
   
8.             Set 连接 = CreateObject("ADODB.Connection")
   
9.             连接.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & 路径 & 外薄
   
10.             Set 记录 = 连接.OpenSchema(20)
    
11.             Do Until 记录.EOF
    
12.                 If 记录.Fields("TABLE_TYPE") = "TABLE" Then
    
13.                     外表 = Replace(记录("TABLE_NAME").Value, "'", "")
    
14.                     If Right(外表, 1) = "$" Then
    
15.                         SQL = "select * from [" & 外表 & "] where 物品 is not null"
    
16.                         记录数组 = 连接.Execute(SQL).GetRows
    
17.                         For 行 = 0 To UBound(记录数组, 2)
    
18.                             条件列 = 记录数组(0, 行) & 记录数组(1, 行)
    
19.                             If Not 字典.Exists(条件列) Then
    
20.                                 计数器 = 计数器 + 1
    
21.                                 字典(条件列) = 计数器
    
22.                                 For 列 = 0 To 2
    
23.                                     结果数组(计数器, 列) = 记录数组(列, 行)
    
24.                                 Next
    
25.                             Else
    
26.                                 结果数组(字典(条件列), 2) = 结果数组(字典(条件列), 2) + 记录数组(2, 行)
    
27.                             End If
    
28.                         Next
    
29.                     End If
    
30.                 End If
    
31.                 记录.MoveNext
    
32.             Loop
    
33.         End If
    
34.         外薄 = Dir()
    
35.     Loop
    
36.     ActiveSheet.UsedRange.Offset(1).ClearContents
    
37.     [a2].Resize(计数器, 3) = 结果数组
    
38.     记录.Close: Set 记录 = Nothing
    
39.     连接.Close: Set 连接 = Nothing
    
40. End Sub

复制代码

LMY123

相同数据同行存放--ADO法-字典法

http://club.excelhome.net/thread-1351275-2-1.html
http://club.excelhome.net/thread-1355859-2-1.html

18868103186

谢谢楼主分享

wowpod

楼主，请你完成我的程序！

DDBB2008

感谢分享，学习学习