Option Explicit
Sub CountTXT()
Dim fullKeys As String, fullData As String
Dim aFiles As Variant
aFiles = ShowFileDialog(True)
If IsEmpty(aFiles) Then Exit Sub
fullKeys = aFiles(1)
If UBound(aFiles) = 1 Then
aFiles = ShowFileDialog(False)
If IsEmpty(aFiles) Then Exit Sub
fullData = aFiles(1)
Else
fullData = aFiles(2)
End If
CloseEmptyWb
Dim dic As Object
Set dic = ReadTXT(fullKeys, fullData)
Dim aMax As Variant
aMax = GetMaxArray(dic, 10)
PrintArray aMax, Workbooks.Add(1).Sheets(1).Cells(1, 1)
End Sub
Private Sub PrintArray(arr As Variant, rr As Range)
Set rr = rr.Resize(UBound(arr, 1), UBound(arr, 2))
rr.Value = arr
End Sub
Private Function GetMaxArray(dic As Object, nMax As Long) As Variant
Dim krr As Variant, jrr As Variant, mm As Long
krr = dic.Keys()
jrr = dic.Items()
Dim res As Variant, ya As Long, jj As Long
ReDim res(1 To nMax, 1 To 2)
For ya = 1 To nMax
mm = WorksheetFunction.Max(jrr)
If mm = 0 Then Exit For
jj = WorksheetFunction.Match(mm, jrr, 0)
jj = jj - 1
res(ya, 1) = krr(jj)
res(ya, 2) = jrr(jj)
jrr(jj) = 0
Next
GetMaxArray = res
End Function
Private Function ReadTXT(fullKeys As String, fullData As String) As Object
Const BUFFSIZE = 100000
Dim fso As Object 'New FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
Dim ss As String, arr As Variant, ya As Long
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Application.StatusBar = "Читаю файл " & fso.GetBaseName(fullKeys)
With fso.OpenTextFile(fullKeys, 1)
Do
If .AtEndOfStream Then Exit Do
ss = .Read(BUFFSIZE)
If Not .AtEndOfStream Then ss = ss & .ReadLine
arr = Split(ss, vbCrLf)
For ya = LBound(arr) To UBound(arr)
If arr(ya) <> "" Then
dic(arr(ya)) = 0
End If
Next
DoEvents
Loop
.Close
End With
Application.StatusBar = "Читаю файл " & fso.GetBaseName(fullData)
With fso.OpenTextFile(fullData, 1)
Do
If .AtEndOfStream Then Exit Do
ss = .Read(BUFFSIZE)
If Not .AtEndOfStream Then ss = ss & .ReadLine
arr = Split(ss, vbCrLf)
For ya = LBound(arr) To UBound(arr)
If arr(ya) <> "" Then
If dic.Exists(arr(ya)) Then
dic(arr(ya)) = dic(arr(ya)) + 1
End If
End If
Next
DoEvents
Loop
.Close
End With
Application.StatusBar = False
Set ReadTXT = dic
End Function
Private Sub CountRange(condRange As Range, dataRange As Range, outputRange As Range)
Dim arr As Variant
arr = Intersect(condRange, condRange.Parent.UsedRange).Value
Dim brr As Variant
brr = Intersect(dataRange, dataRange.Parent.UsedRange).Value
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Dim ya As Long
For ya = 1 To UBound(arr, 1)
dic(arr(ya, 1)) = 0
Next
For ya = 1 To UBound(brr, 1)
If dic.Exists(brr(ya, 1)) Then
dic(brr(ya, 1)) = dic(brr(ya, 1)) + 1
End If
Next
ReDim brr(1 To UBound(arr, 1), 1 To 1)
For ya = 1 To UBound(arr, 1)
brr(ya, 1) = dic(arr(ya, 1))
Next
outputRange.Resize(UBound(brr, 1), UBound(brr, 2)).Value = brr
End Sub
Private Function ShowFileDialog(bAllowMultiSelect As Boolean) As Variant
'ShowFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Static sInitialFileName As String
If sInitialFileName = "" Then sInitialFileName = ThisWorkbook.Path & "\"
Dim oFD As FileDialog
Dim lf As Long
'назначаем переменной ссылку на экземпляр диалога
Set oFD = Application.FileDialog(msoFileDialogFilePicker)
With oFD 'используем короткое обращение к объекту
'так же можно без oFD
'With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = bAllowMultiSelect
.Title = IIf(bAllowMultiSelect, "Выбрать файлы", "Выбрать файл") 'заголовок окна диалога
.Filters.Clear 'очищаем установленные ранее типы файлов
'.Filters.Add "Excel files", "*.xls*", 1 'устанавливаем возможность выбора только файлов Excel
.Filters.Add "Text files", "*.txt", 1 'добавляем возможность выбора текстовых файлов
.FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
.InitialFileName = sInitialFileName
.InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
If .Show = 0 Then Exit Function 'показывает диалог
Dim arr As Variant, sName As String
'цикл по коллекции выбранных в диалоге файлов
For lf = 1 To .SelectedItems.Count
sName = fso.GetFileName(.SelectedItems(lf))
If Left(sName, 2) <> "~$" Then
If sName <> ThisWorkbook.Name Then
If IsEmpty(arr) Then
ReDim arr(1 To 1)
Else
ReDim Preserve arr(1 To UBound(arr) + 1)
End If
arr(UBound(arr)) = .SelectedItems(lf) 'считываем полный путь к файлу
sInitialFileName = arr(UBound(arr))
End If
End If
Next
ShowFileDialog = arr
End With
End Function
Private Sub CloseEmptyWb()
Dim wb As Workbook
For Each wb In Application.Workbooks
If wb.Path = "" Then wb.Close False
Next
End Sub
|
