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