ExcelTip.Net留存知识帖 ---【注：附件之前被网盘供应商清空后，现已修复-现已修复-现已修复为本地下载！】
现在位置：首页 > E问E答 > Excel VBA > 如何对选定的多个文本文件内容求交集？

如何对选定的多个文本文件内容求交集？

作者：绿色风 分类： 时间：2022-08-17 浏览：159
楼主
amulee		 Q：如何对选定的多个文本文件内容求交集？
A：如附件。每个文本都含有数量不等的由六个数字组成的六位数字字符串。现在，希望对所选的文本文件针对这一系列六个数字进行交集计算，即选定的文本文件所共有的六位数字字符串。
可参考以下方法：
由于数据量巨大，为提高速度，采取两个字典。基本思想是当读取到N个文本文件时，清空当前使用的字典，然后读取数据，判断当前元素是否存在于前一个文件处理后的字典中。如果存在，则在当前字典添加元素。两字典交替使用，直至文本文件遍历完毕。代码如下：
  1. Sub 交集_字典法()
  2.     Dim ArrFile
  3.     Dim ArrD(1) As New Dictionary
  4.     Dim i&, j&, FileCount%, FS%, Temp$, DNow%, DPre%
  5.     t = Timer
  6.     '选择文件
  7.     With Application.FileDialog(msoFileDialogOpen)
  8.         .Filters.Add "文本文件", "*.txt", 1
  9.         If .Show = -1 Then
  10.             FileCount = .SelectedItems.Count
  11.             If FileCount = 1 Then
  12.                 MsgBox "至少选择两个以上文件"
  13.                 Exit Sub
  14.             End If
  15.             ReDim ArrFile(1 To FileCount)
  16.             For i = 1 To FileCount
  17.                 ArrFile(i) = .SelectedItems(i)
  18.             Next i
  19.         Else
  20.             MsgBox "未选择任何文件"
  21.             Exit Sub
  22.         End If
  23.     End With
  24.     '第一个文件。加入字典
  25.     FS = FreeFile
  26.     Open ArrFile(1) For Input As #FS
  27.     Do While Not EOF(FS)
  28.         Line Input #FS, Temp
  29.         ArrD(1)(Temp) = 1
  30.     Loop
  31.     Close #FS
  32.     '读取剩余文件。并加入字典。两字典交替用
  33.     Set d = CreateObject("Scripting.Dictionary")
  34.     For i = 2 To FileCount
  35.         DNow = i Mod 2
  36.         If DNow = 0 Then DPre = 1 Else DPre = 0
  37.         ArrD(DNow).RemoveAll
  38.         FS = FreeFile
  39.         Open ArrFile(i) For Input As #FS
  40.         Do While Not EOF(FS)
  41.             Line Input #FS, Temp
  42.             If ArrD(DPre).Exists(Temp) Then ArrD(DNow)(Temp) = 1
  43.         Loop
  44.         Close #FS
  45.     Next i
  46.     '清空数组
  47.     Erase ArrFile
  48.     ArrFile = ArrD(DNow).keys
  49.     '输出文件
  50.     FS = FreeFile
  51.     Open ThisWorkbook.Path & "\交集+" & ArrD(DNow).Count & ".txt" For Output As #FS
  52.     Print #FS, Join(ArrFile, vbCrLf)
  53.     Close #FS
  54.     MsgBox "耗时:" & Timer - t
  55. End Sub

如何对选定的文本文件内容求交集？.rar
2楼
amulee		 上述代码还可以优化，因为不断对字典对象进行操作将会拖慢速度。所以将第一个文件选为最小的那个文件，即元素最少的文件。让第一次的字典就最接近最终结果，保证字典元素数量减少，也减少每次查找重复的概率。
  1. Sub 交集_字典法()
  2.     Dim ArrFile
  3.     Dim ArrD(1) As New Dictionary
  4.     Dim i&, j&, FileCount%, FS%, Temp$, DNow%, DPre%
  5.     '选择文件
  6.     With Application.FileDialog(msoFileDialogOpen)
  7.         .Filters.Add "文本文件", "*.txt", 1
  8.         If .Show = -1 Then
  9.             t = Timer
  10.             FileCount = .SelectedItems.Count
  11.             If FileCount = 1 Then
  12.                 MsgBox "至少选择两个以上文件"
  13.                 Exit Sub
  14.             End If
  15.             ReDim ArrFile(1 To 2, 1 To FileCount)
  16.             For i = 1 To FileCount
  17.                 ArrFile(1, i) = .SelectedItems(i)
  18.                 ArrFile(2, i) = FileLen(ArrFile(1, i))
  19.             Next i
  20.         Else
  21.             MsgBox "未选择任何文件"
  22.             Exit Sub
  23.         End If
  24.     End With
  25.     '设定第一个文件为最小的文件，保证字典访问次数少
  26.     j = 1
  27.     For i = 2 To FileCount
  28.         If ArrFile(2, i) < ArrFile(2, j) Then j = i
  29.     Next i
  30.     If j <> 1 Then
  31.         Temp = ArrFile(1, j)
  32.         ArrFile(1, j) = ArrFile(1, 1)
  33.         ArrFile(1, 1) = Temp
  34.     End If
  35.     '第一个文件。加入字典
  36.     FS = FreeFile
  37.     Open ArrFile(1, 1) For Input As #FS
  38.     Do While Not EOF(FS)
  39.         Line Input #FS, Temp
  40.         ArrD(1)(Temp) = 1
  41.     Loop
  42.     Close #FS
  43.     '读取剩余文件。并加入字典。两字典交替用
  44.     Set d = CreateObject("Scripting.Dictionary")
  45.     For i = 2 To FileCount
  46.         DNow = i Mod 2
  47.         If DNow = 0 Then DPre = 1 Else DPre = 0
  48.         ArrD(DNow).RemoveAll
  49.         FS = FreeFile
  50.         Open ArrFile(1, i) For Input As #FS
  51.         Do While Not EOF(FS)
  52.             Line Input #FS, Temp
  53.             If ArrD(DPre).Exists(Temp) Then ArrD(DNow)(Temp) = 1
  54.         Loop
  55.         Close #FS
  56.     Next i
  57.     '清空数组
  58.     Erase ArrFile
  59.     ArrFile = ArrD(DNow).keys
  60.     '输出文件
  61.     FS = FreeFile
  62.     Open ThisWorkbook.Path & "\交集+" & ArrD(DNow).Count & ".txt" For Output As #FS
  63.     Print #FS, Join(ArrFile, vbCrLf)
  64.     Close #FS
  65.     MsgBox "耗时:" & Timer - t
  66. End Sub
3楼
amulee		 再补充一种方法。SQL法，适用于数据量更大的情形。
  1. Sub 交集_ADO_SQL法()
  2.     Dim AdoConn As Object
  3.     Dim AdoRec As Object
  4.     Dim Sql$, i&, FileCount%, sPath$, FS%
  5.     Dim ArrFile
  6.     On Error Resume Next
  7.     '选择文件
  8.     ReDim ArrFile(1 To 1)
  9.     If Range("B5") <> "" Then ChDir Range("B5").Value  '文件路径
  10.     '选择文件
  11.     With Application.FileDialog(msoFileDialogOpen)
  12.         .Filters.Add "文本文件", "*.txt", 1
  13.         If .Show = -1 Then
  14.             t = Timer
  15.             FileCount = .SelectedItems.Count
  16.             sPath = .InitialFileName
  17.             If FileCount < 2 Then
  18.                 MsgBox "至少选择两个以上文件"
  19.                 Exit Sub
  20.             End If
  21.             ReDim ArrFile(1 To FileCount)
  22.             For i = 1 To FileCount
  23.                 ArrFile(i) = .SelectedItems(i)
  24.                 ArrFile(i) = Mid(ArrFile(i), InStrRev(ArrFile(i), Application.PathSeparator) + 1)
  25.                 Mid(ArrFile(i), Len(ArrFile(i)) - 3, 1) = "#"
  26.             Next i
  27.         Else
  28.             MsgBox "未选择任何文件"
  29.             Exit Sub
  30.         End If
  31.     End With
  32.     '输出文件名
  33.     With Sheet1
  34.         .Range("B3:J3").ClearContents
  35.         .Range("B3").Resize(1, FileCount) = WorksheetFunction.Index(ArrFile, 1, 0)
  36.     End With
  37.     '编写SQL语句
  38.     Sql = "Select F1 from [" & ArrFile(1) & "]"
  39.     For i = 2 To FileCount
  40.         Sql = "Select F1 from [" & ArrFile(i) & "] where F1 in (" & Sql & ")"
  41.     Next i
  42.    
  43.     '创建数据库连接
  44.     Set AdoConn = CreateObject("ADODB.Connection")
  45.     Set AdoRec = CreateObject("ADODB.Recordset")
  46.     AdoConn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
  47.                  "Data Source=" & sPath & ";" & _
  48.                  "Extended Properties=""Text;HDR=No;IMEX=1"";"
  49.     Set AdoRec = AdoConn.Execute(Sql)   '执行查询
  50.     ArrFile = AdoRec.GetRows    '获取结果数组
  51.     '关闭ADO对象
  52.     AdoRec.Close
  53.     AdoConn.Close
  54.     Set AdoConn = Nothing
  55.     Set AdoRec = Nothing
  56.     Debug.Print Timer - t
  57.     '写入文本文件
  58.     FS = FreeFile
  59.     Open ThisWorkbook.Path & "\交集+" & UBound(ArrFile, 2) + 1 & ".txt" For Output As #FS
  60.     For i = 0 To UBound(ArrFile, 2)
  61.         Print #FS, Trim(ArrFile(0, i))
  62.     Next i
  63.     Close #FS
  64.     MsgBox "耗时:" & Timer - t
  65. End Sub
4楼
amulee		 再补充一种计数法，此法受内存限制。目前我的电脑只能处理6位数的文件，如果7位数就会溢出。此法从速度上比上述两种方法都要快很多，但是只能适用于数字的情形。
  1. Sub 交集_计数法()   '仅限于数字
  2.     Dim ArrFile
  3.     Dim i&, j&, FileCount%, FS%, k&, Temp$
  4.     Dim ArrTxt, ArrTxtTemp, ArrCount() As Integer, LenT%
  5.     Dim ArrJG
  6.     Dim FSO As Object
  7.     Dim Bln As Boolean
  8.     On Error Resume Next
  9.     '选择文件
  10.     ReDim ArrFile(1 To 2, 1 To 1)
  11.     If Range("B5") <> "" Then ChDir Range("B5").Value  '文件路径
  12.     '选择文件
  13.     With Application.FileDialog(msoFileDialogOpen)
  14.         .Filters.Add "文本文件", "*.txt", 1
  15.         If .Show = -1 Then
  16.             t = Timer
  17.             FileCount = .SelectedItems.Count
  18.             If FileCount < 2 Then
  19.                 MsgBox "至少选择两个以上文件"
  20.                 Exit Sub
  21.             End If
  22.             ReDim ArrFile(1 To 2, 1 To FileCount)
  23.             For i = 1 To FileCount
  24.                 ArrFile(1, i) = .SelectedItems(i)
  25.                 ArrFile(2, i) = FileLen(ArrFile(1, i))
  26.             Next i
  27.         Else
  28.             MsgBox "未选择任何文件"
  29.             Exit Sub
  30.         End If
  31.     End With
  32.     '输出文件名
  33.     With Sheet1
  34.         .Range("B3:J3").ClearContents
  35.         .Range("B3").Resize(1, FileCount) = WorksheetFunction.Index(ArrFile, 1, 0)
  36.     End With
  37.     '读取所有文件
  38.     Set FSO = CreateObject("Scripting.FileSystemObject")
  39.     ReDim ArrTxt(1 To FileCount)
  40.     For i = 1 To FileCount
  41.         With FSO.OpenTextFile(ArrFile(1, i))
  42.             ArrTxt(i) = Split(.ReadAll, vbCrLf)
  43.             .Close
  44.         End With
  45.     Next i
  46.     LenT = Len(ArrTxt(1)(0))
  47.     ReDim ArrCount(1 To 10 ^ LenT - 1)
  48.     Debug.Print Timer - t
  49.     '遍历其他文件
  50.     For i = 1 To FileCount
  51.         '逐个比较
  52.         For j = 0 To UBound(ArrTxt(i))
  53.             k = Val(ArrTxt(i)(j))
  54.             If i - ArrCount(k) = 1 Then ArrCount(k) = ArrCount(k) + 1
  55.         Next j
  56.     Next i
  57.     '输出文件
  58.     FS = FreeFile
  59.     k = 0
  60.     Open ThisWorkbook.Path & "\" & FS & ".txt" For Output As #FS
  61.     For i = 1 To UBound(ArrCount)
  62.         If ArrCount(i) = FileCount Then
  63.             Print #FS, Format(i, String(LenT, "0"))
  64.             k = k + 1
  65.         End If
  66.     Next i
  67.     Close #FS
  68.     Kill ThisWorkbook.Path & "\交集+" & k & ".txt"
  69.     Name ThisWorkbook.Path & "\" & FS & ".txt" As ThisWorkbook.Path & "\交集+" & k & ".txt"
  70.     MsgBox "耗时:" & Timer - t
  71. End Sub
5楼
lrlxxqxa		 精彩！

免责声明

有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素， 经与ExcelTip.Net站长Apolloh商议并征得其同意， 现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示， 供有需要的人士查询使用，也慰缅曾经的论坛时代。 所示各个帖子的原作者如对版权有异议， 可与本人沟通提出，或于本站点留言，我们会尽快处理。 在此，感谢ExcelTip.Net站长Apolloh的支持，感谢本站点所有人**绿色风（QQ:79664738)**的支持与奉献，特此鸣谢！
------本人网名**KevinChengCW（QQ:1210618015)**原ExcelTip.Net总版主之一

猜您喜欢
评论列表
搜索

鄂ICP备2021011689号-2

powered by emlog pro Theme By 蓝叶

sitemap