Добрый день...У меня есть табличка в Excel,для неё написан Макрос.
Макрос выделяет определенным цветом,те вещи которые сделанны или не сделанны..
Но после того как поменяли одно название в Макросе,он почему то именно с одним названием,неправильно выдает ответ,не правильно работает...Как мне это исправить?кто то реально может в этом помочь!!!
Sub CheckAll()
Dim i As Integer
Dim j As Integer
Dim PathFull As String
Dim PathTemp As String
Dim FileNotFound As Long
Dim NoteNotFound As Long
Dim DoubleNote As Long
Dim LastCol As Integer
Dim LastRow As Long
Dim MyName As String
Dim MyPath As String
Dim FindBool As Byte
Dim FolderID As Byte
Dim FileID As Byte
Dim DateID As Byte
Dim ErrorBool As Boolean
Dim LastNumberAdd As Integer
Dim RemoveFileName As String
'Пареметры:
PathFull = Sheets("Options").Cells(1, 2)
PathTemp = Sheets("Options").Cells(2, 2)
FileNotFound = Sheets("Options").Cells(3, 2).Interior.Color
NoteNotFound = Sheets("Options").Cells(4, 2).Interior.Color
DoubleNote = Sheets("Options").Cells(5, 2).Interior.Color
LastNumberAdd = 1
Sheets("Data").Select
With ActiveSheet
LastCol = .Range("A1").End(xlToRight).Column
For i = 1 To LastCol
.Cells(1, i).Interior.Color = Sheets("Options").Cells(6, 2).Interior.Color
Select Case .Cells(1, i)
Case "Êîíòðàãåíò": FolderID = i
Case "Íîìåð": FileID = i
Case "ÇàïàêîâàíîÄàòà": DateID = i
End Select
Next
LastRow = .Cells(65536, FolderID).End(xlUp).Row
'Удаляем розовые",
For i = 2 To LastRow
For j = 1 To LastCol
If .Cells(i, j).Interior.Color = NoteNotFound Then
.Cells(i, j) = ""
End If
.Cells(i, j).Interior.Color = RGB(255, 255, 255)
Next
Next
'Сортируем:
.Range(Cells(2, 1), Cells(LastRow, LastCol)).Sort Cells(1, FolderID), , Cells(1, FileID)
LastRow = .Cells(65536, FolderID).End(xlUp).Row
'Проверяем:
For i = 2 To LastRow + 1
FindBool = 2
If i > 2 Then
If MyPath = .Cells(i, FolderID) Then
If MyName = .Cells(i, FileID) Then FindBool = 1
Else
MyName = Dir(PathTemp & MyPath & "\", vbDirectory)
Do While MyName <> ""
If MyName <> "." And MyName <> ".." Then
j = i - 1
ErrorBool = False
While MyPath = .Cells(j, FolderID) And j > 1
If InStr(1, MyName, .Cells(j, FileID)) <> 0 Then ErrorBool = True
j = j - 1
Wend
If Not ErrorBool Then
.Cells(LastRow + LastNumberAdd, FolderID) = MyPath
If Right(MyName, 4) = ".pdf" Or Right(MyName, 4) = ".jpg" Then
If InStr(1, MyName, "îò") <> 0 And DateID <> 0 Then
.Cells(LastRow + LastNumberAdd, FileID) = Left(MyName, InStr(1, MyName, "îò") - 1)
.Cells(LastRow + LastNumberAdd, DateID) = Left(Right(MyName, Len(MyName) - InStr(1, MyName, "îò") - 2), Len(Right(MyName, Len(MyName) - InStr(1, MyName, "îò") - 2)) - 4)
Else
.Cells(LastRow + LastNumberAdd, FileID) = Left(MyName, Len(MyName) - 4)
End If
Else
.Cells(LastRow + LastNumberAdd, FileID) = MyName
End If
For j = 1 To LastCol
.Cells(LastRow + LastNumberAdd, j).Interior.Color = NoteNotFound
Next
LastNumberAdd = LastNumberAdd + 1
End If
End If
MyName = Dir
Loop
End If
End If
If i < LastRow + 1 Then
MyPath = .Cells(i, FolderID)
If FindBool = 2 Then
'Проверяем в постоянной папке
MyName = Dir(PathFull & MyPath & "\", vbDirectory)
Do While MyName <> ""
If MyName <> "." And MyName <> ".." Then
If InStr(1, MyName, .Cells(i, FileID)) <> 0 Then
FindBool = 0
End If
End If
MyName = Dir
Loop
'Если не находим ,проверяем во временной
If FindBool <> 0 Then
MyName = Dir(PathTemp & MyPath & "\", vbDirectory)
Do While MyName <> ""
If MyName <> "." And MyName <> ".." Then
If InStr(1, MyName, .Cells(i, FileID)) <> 0 Then
FindBool = 0
RemoveFileName = MyName
End If
End If
MyName = Dir
Loop
'Если находим во временной,то перемещаем в постоянную
If FindBool = 0 Then
If Dir(PathFull & MyPath & "\" & MyName) <> MyName Then
Name PathTemp & MyPath & "\" & RemoveFileName As PathFull & MyPath & "\" & RemoveFileName
End If
End If
End If
End If
MyName = .Cells(i, FileID)
For j = 1 To LastCol
Select Case FindBool
Case 0: .Cells(i, j).Interior.Color = RGB(255, 255, 255)
Case 1: .Cells(i, j).Interior.Color = DoubleNote
Case 2: .Cells(i, j).Interior.Color = FileNotFound
End Select
Next
End If
Next
End With
End Sub
