Что можете посоветовать?
Код: Выделить всё
Sub Avtomat()
Dim xxStroka, xxStolbec, xxSize, xxSize2, xkkk, i As Integer
Dim xxNameIst, xxS, xFileK, xa, xxBukva, xxK, xxK2, xDate3 As String
ActiveSheet.Unprotect
Application.ScreenUpdating = False
xFileK = "D:\ini\spisok.txt" 'файл формата: "CAZ - 1,2"
xxStroka = 4
xxStolbec = 2
While Worksheets("Лист1").Cells(xxStroka, xxStolbec).Value <> ""
xxStroka = xxStroka + 1
Wend
xkkk = 0
xDate3 = Format(Date, "yyyy")
For i = 4 To xxStroka
If Worksheets("Лист1").Cells(i, 6).Interior.ColorIndex = 6 Then
xxNameIst = Right(Cells(i, 5), 7)
With Application.FileSearch
.LookIn = "D:\СКАНЫ\" & xDate3 & "\" 'папка с файлами
.SearchSubFolders = True
.FileType = msoFileTypeAllFiles
.FileName = "mv?" & xxNameIst & ".txt"
'вот здесь я понимаю он ищет все вхождения
'а было бы хорошо чтоб он нашел файл и начал уже выполнять операцию с этим вхождением
If .Execute >= 1 Then
xa = .FoundFiles(1)
xxSize = Fix(FileLen(xa) / 1024) + 2
xxBukva = Mid(xa, Len(xa) - 10, 3)
Cells(i, 6).Value = xxSize
Cells(i, 6).Interior.ColorIndex = 0
xkkk = xkkk + 1
Open xFileK For Input As #1
Do While Not EOF(1)
Line Input #1, xxS
xxK = LCase(Left(xxS, 3))
xxSize2 = 0
If xxBukva = xxK Then
xxK2 = Right(xxS, 3)
xxSize2 = Fix(xxSize * xxK2 - xxSize)
End If
Loop
Close #1
If xxSize2 <> 0 Then
Cells(i, 7).Value = xxSize2
Cells(i, 7).Interior.ColorIndex = 0
End If
End If
End With
End If
Next i
MsgBox xkkk
Application.ScreenUpdating = True
End Sub