Function FilenamesCollection ByVal FolderPath As String Optional ByVal

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", Optional ByVal SearchDeep As Long = 999) As Collection
' ïîëó÷àåò â êà÷åñòâå ïàðàìåòðà ïóòü ê ïàïêå FolderPath,
' ìàñêó èìåíè èñêîìûõ ôàéëîâ Mask (áóäóò îòîáðàíû òîëüêî ôàéëû ñ òàêîé ìàñêîé/ðàçðåøåíèåì)
' è ãëóáèíó ïîèñêà SearchDeep â ïîäïàïêàõ (åñëè SearchDeep = 1, òî ïîäïàïêè íå ïðîñìàòðèâàþòñÿ)
' âîçâðàùàåò êîëëåêöèþ, ñîäåðæàùóþ ïîëíûå ïóòè íàéäåíûõ ôàéëîâ
' ïðèìåíÿåòñÿ ðåêóðñèâíûé âûçîâ ïðîöåäóðû GetAllFileNamesUsingFSO
Set FilenamesCollection = New Collection
Set FSO = CreateObject("Scripting.FileSystemObject")
GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep
Set FSO = Nothing: Application.StatusBar = False
End Function
Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
' ïåðåáèðàåò âñå ôàéëû è ïîäïàïêè â ïàïêå FolderPath, èñïîëüçóÿ îáúåêò FSO
' ïåðåáîð ïàïîê îñóùåñòâëÿåòñÿ â òîì ñëó÷àå, åñëè SearchDeep > 1
' äîáàâëÿåò ïóòè íàéäåííûõ ôàéëîâ â êîëëåêöèþ FileNamesColl
On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
If Not curfold Is Nothing Then
For Each fil In curfold.Files ' ïåðåáèðàåì âñå ôàéëû â ïàïêå FolderPath
If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.path
Next
SearchDeep = SearchDeep - 1 ' óìåíüøàåì ãëóáèíó ïîèñêà â ïîäïàïêàõ
If SearchDeep Then ' åñëè íàäî èñêàòü ãëóáæå
For Each sfol In curfold.SubFolders ' ïåðåáèðàåì âñå ïîäïàïêè â ïàïêå FolderPath
GetAllFileNamesUsingFSO sfol.path, Mask, FSO, FileNamesColl, SearchDeep
Next
End If
Set fil = Nothing: Set curfold = Nothing ' î÷èùàåì ïåðåìåííûå
End If
End Function
Function ReadClient()
' çàïèñûâàåò êîëëåêöèþ êíèã ñ äàííûìè î êëèåíòàõ
Application.DisplayAlerts = False
On Error Resume Next
new_path = "C:\Users\evgeny\Desktop\ÈÄÇ ¹3\Çàíÿòèå 6 äëÿ ñòóäåíòîâ\Ïðîäàæè.Êëèåíòû\" ' ñîçäà¸ì äèðåêòîðèþ, â êîòîðîé áóäåì õðàíèòü êíèãè ñ îò÷¸òàìè î ïîêóïêàõ âñåõ êëèåíòîâ
' åñëè äàííàÿ äèðåêòîðèÿ ñóùåñòâóåò, òî èñêëþ÷àåì ïåðåçàïèñü
If Dir(new_path, vbDirectory) = "" Then
MkDir (new_path) ' ñîçäà¸ì äèðåêòîðèþ "Ïðîäàæè.Êëèåíòû" ïî óêàçàííîìó ïóòè
folder = "C:\Users\evgeny\Desktop\ÈÄÇ ¹3\Çàíÿòèå 6 äëÿ ñòóäåíòîâ\Ïðîäàæè\"
general_path = ThisWorkbook.path
Set general_WB = Application.Workbooks.Add ' âñïîìîãàòåëüíàÿ êíèãà äëÿ ïàðñèíãà êëèåíòîâ
' ïðîâåðêà íà ñóùåñòâîâàíèå äèðåêòîðèè
If Dir(folder, vbDirectory) = "" Then
MsgBox ("Äàííàÿ äèðåêòîðèÿ íå íàéäåíà")
Exit Function
End If
' ñîçäà¸ì êîëëåêöèþ êíèã òåêóùåé äèðåêòîðèè
Set coll = FilenamesCollection(folder, "*.xls")
' ïðîâåðêà íà ïóñòîòó êîëëåêöèè
If coll.Count = 0 Then
MsgBox ("Äàííàÿ äèðåêòîðèÿ ïóñòà")
End If
' ïåðåáèðàåì êîëëåêöèþ è çàïèñûâàåì ïîëó÷åííûå îò÷¸íû â íîâóþ äèðåêòîðèþ
For i = 1 To 3
' ïàðñèíã êëèåíòà
Workbooks.Open coll.Item(i)
Set cur_WB = ActiveWorkbook
general_WB.Sheets(1).Cells(i + 1, 1) = cur_WB.Sheets(1).Cells(2, 2)
general_WB.Sheets(1).Cells(i + 1, 2).FormulaR1C1 = "=TRIM(MID(RC[-1],FIND(""Êëèåíò:"",RC[-1]) + 8,LEN(RC[-1]) + 6))"
clients_name = general_WB.Sheets(1).Cells(i + 1, 2).Value
cur_name = clients_name & ".xls"
' åñëè êëèåíò ïîâòîðÿåòñÿ, òî äîáàâëÿì äàííûå â ðàíåå ñîçäàííóþ äëÿ íåãî êíèãó
rep_name = Dir(new_path, vbDirectory)
Do While rep_name <> ""
If rep_name <> "." And rep_name <> ".." Then
If rep_name Like "*.xls" And cur_name = rep_name Then
Workbooks.Open new_path & rep_name
Set cur2_WB = ActiveWorkbook
cur_row = cur_WB.Sheets(1).Cells(1, 1).CurrentRegion.Rows.Count + 1
work_row = cur_WB2.Sheets(1).Cells(1, 1).CurrentRegion.Rows.Count - 2
y = 3
For j = cur_row To work_row + cur_row
For k = 1 To 4
cur_WB.Sheets(1).Cells(j, k) = cur_WB2.Sheets(1).Cells(y, k)
Next
y = y + 1
Next
cur_WB2.Close
End If
End If
rep_name = Dir
Loop
cur_WB.SaveAs (new_path & clients_name)
cur_WB.Close
Next
Exit Function
End If
End Function
Function AddClientsToListBox()
first_path = "C:\Users\evgeny\Desktop\ÈÄÇ ¹3\Çàíÿòèå 6 äëÿ ñòóäåíòîâ\Ïðîäàæè2\"
Myname = Dir(first_path, vbDirectory)
Do While Myname <> ""
If Myname <> "." And Myname <> ".." Then
If Myname Like "*.xls" Then
UserForm1.ListBox1.AddItem ((Replace(Myname, ".xls", "")))
End If
End If
Myname = Dir
Loop
End Function
Sub GetReportAboutClient()
first_path = "C:\Users\evgeny\Desktop\ÈÄÇ ¹3\Çàíÿòèå 6 äëÿ ñòóäåíòîâ\Ïðîäàæè2\"
cur_name = UserForm1.ListBox1.Text & ".xls"
Myname = Dir(first_path, vbDirectory)
Do While Myname <> ""
If Myname <> "." And Myname <> ".." Then
If Myname Like "*.xls" And Myname = cur_name Then
Workbooks.Open first_path & Myname
End If
End If
Myname = Dir
Loop
End Sub