Option Explicit
Const RowStart = 3
Const ColStart = 2
Dim objFSO As Object, objFolder As Object, objFile As Object
Sub workfile(filePath As String)
Dim wtemp As Worksheet
Dim wdb As Worksheet
Dim marsh As String
Dim tempstring As String, tempotdel As String, tempoper As String, tempcaption As String
Dim i As Integer
Dim startCell As Range
Application.ScreenUpdating = False
Set wtemp = Worksheets("Temp")
Set wdb = Worksheets("БД")
Worksheets("Temp").Cells.Clear
On Error Resume Next
loadfile (filePath)
Set startCell = Worksheets("Temp").Cells.Find(What:="ЯкорьМакроса", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False)
If InStr(startCell.Offset(0, 1), "(") <> 0 Then
wdb.Cells(RowStart + Range("TPCount"), ColStart + 1) = myTrim(Left(startCell.Offset(0, 1), InStr(startCell.Offset(0, 1), "(") - 1)) & ";" & myTrim(Mid(startCell.Offset(0, 1), InStr(startCell.Offset(0, 1), "(")))
Else
wdb.Cells(RowStart + Range("TPCount"), ColStart + 1) = myTrim(startCell.Offset(0, 1))
End If
wdb.Cells(RowStart + Range("TPCount"), ColStart + 2) = myTrim(startCell.Offset(1, 1))
wdb.Cells(RowStart + Range("TPCount"), ColStart + 3) = myTrim(startCell.Offset(2, 1))
If InStr(startCell.Offset(3, 1), "+") Then
wdb.Cells(RowStart + Range("TPCount"), ColStart + 4) = myTrim(Left(startCell.Offset(3, 1), InStr(startCell.Offset(3, 1), "+") - 1)) & ";" & myTrim(Mid(startCell.Offset(3, 1), InStr(startCell.Offset(3, 1), "+")))
Else
wdb.Cells(RowStart + Range("TPCount"), ColStart + 4) = myTrim(startCell.Offset(3, 1))
End If
wdb.Cells(RowStart + Range("TPCount"), ColStart + 5) = myTrim(startCell.Offset(4, 1))
wdb.Cells(RowStart + Range("TPCount"), ColStart + 6) = myTrim(startCell.Offset(5, 1))
wdb.Cells(RowStart + Range("TPCount"), ColStart + 7) = myTrim(startCell.Offset(6, 1))
wdb.Cells(RowStart + Range("TPCount"), ColStart + 8) = myTrim(startCell.Offset(7, 1))
wdb.Cells(RowStart + Range("TPCount"), ColStart + 10) = filePath
marsh = ""
tempstring = ""
tempotdel = ""
tempoper = ""
tempcaption = ""
Set startCell = Worksheets("Temp").Cells.Find(What:="Якорь2", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Offset(-2, 0)
For i = 3 To 303
If (startCell.Offset(i, 0) = "Ошибка") Then
Exit For
End If
If (startCell.Offset(i, 1)) <> "" Then
If tempoper <> "" Then
tempstring = tempotdel & "$" & tempoper & "$" & tempcaption & "@"
marsh = marsh & tempstring
End If
tempstring = ""
tempotdel = myTrim(startCell.Offset(i, 0))
tempoper = Format(CInt(startCell.Offset(i, 1)), "000")
tempcaption = myTrim(startCell.Offset(i, 2))
Else
If (startCell.Offset(i, 0) <> "") Then
tempotdel = tempotdel & ";" & myTrim(startCell.Offset(i, 0))
End If
If (startCell.Offset(i, 2) <> "") Then
tempcaption = tempcaption & " " & myTrim(startCell.Offset(i, 2))
End If
End If
Next i
marsh = marsh & tempotdel & "$" & tempoper & "$" & tempcaption & "@"
wdb.Cells(RowStart + Range("TPCount"), ColStart + 9) = marsh
wdb.Cells(RowStart + Range("TPCount"), ColStart) = Range("TPCount") + 1
wdb.Activate
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
Sub loadfile(filePath As String)
Dim RngCopy
Dim oWordApl As Object
Dim oDocument As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Set oWordApl = CreateObject("word.application")
Set oDocument = oWordApl.Documents.Open(filePath)
oWordApl.Visible = True
With oWordApl.ActiveDocument
Set RngCopy = .Range(0, .Characters.Count)
RngCopy.Select
oWordApl.Selection.Copy
End With
With Worksheets("Temp")
.Select
.Range("A1").Select
.Paste
End With
oWordApl.ActiveDocument.Close
oWordApl.Visible = False
oWordApl.Quit
Set RngCopy = Nothing
Set oDocument = Nothing
Set oWordApl = Nothing
On Error GoTo 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub Get_All_File_from_SubFolders()
Dim sFolder As String
sFolder = chooseFolder
If sFolder <> "" Then
sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
Application.ScreenUpdating = False
Set objFSO = CreateObject("Scripting.FileSystemObject")
GetSubFolders sFolder
Set objFolder = Nothing
Set objFSO = Nothing
Application.ScreenUpdating = True
End If
End Sub
Private Sub GetSubFolders(sPath)
Set objFolder = objFSO.GetFolder(sPath)
For Each objFile In objFolder.Files
workfile (objFile.path)
ThisWorkbook.Save
Next
For Each objFolder In objFolder.SubFolders
GetSubFolders objFolder.path & Application.PathSeparator
Next
End Sub
Function chooseFolder()
Dim fd As FileDialog
Dim vrtSelectedItem As Variant
Dim path As String
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.ButtonName = "Выбрать"
If .Show = -1 Then
For Each vrtSelectedItem In .SelectedItems
path = vrtSelectedItem
Next vrtSelectedItem
Else
Exit Function
End If
End With
Set fd = Nothing
If path <> "" Then
chooseFolder = path
Else
chooseFolder = ""
End If
End Function
Function myTrim(text As String) As String
text = Trim(text)
Do While InStr(text, " ")
text = Replace(text, " ", " ")
Loop
myTrim = text
End Function
Sub aloneFile()
Dim filePath As String
filePath = Application.GetOpenFilename
If filePath <> "" Then
workfile (filePath)
End If
End Sub
|