Sub Proverka_formatov_v_sobiraemosti()
Dim i As Integer
Dim r As Double
Dim k As Double
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Worksheets("ОШИБКИ").Range("A1:P10000").Clear
ilastrow = Cells(Rows.Count, 1).End(xlUp).Row
ilastcolumn = Rows(2).Find("Реализация", LookIn:=xlValues).Column - 1 ' последний столбец со словом реализация в строке 2
For k = 5 To ilastrow ' цикл перебора по строкам после прохождения всего цикла по столбцам
For i = 15 To ilastcolumn Step 6 ' цикл перебора по столбцам
'проверяем формат данных внесенных в ячейки в столбцах реализация
If WorksheetFunction.IsNumber(Cells(k, i)) Or IsEmpty(Cells(k, i)) Then
Cells(k, i).Interior.Color = xlNone
Else
Cells(k, i).Interior.Color = vbRed
ilastrow = Worksheets("ОШИБКИ").Cells(Rows.Count, 1).End(xlUp).Row + 1
ActiveSheet.Range("B" & k & ":K" & k).Copy Destination:=Worksheets("ОШИБКИ").Cells(ilastrow, 1)
Worksheets("ОШИБКИ").Cells(ilastrow, 11) = ActiveSheet.Cells(4, i).Value
ActiveSheet.Cells(k, i).Copy Destination:=Worksheets("ОШИБКИ").Cells(ilastrow, 12)
Worksheets("ОШИБКИ").Cells(ilastrow, 12).Hyperlinks.Delete
Worksheets("ОШИБКИ").Hyperlinks.Add Anchor:=Worksheets("ОШИБКИ").Cells(ilastrow, 12), Address:="", _
SubAddress:="'" & "отчет" & "'!" & ActiveSheet.Cells(k, i).Address(0, 0), _
ScreenTip:="Перейти на: " & "отчет" & "!" & ActiveSheet.Cells(k, i).Address(0, 0)
End If
'проверяем формат данных внесенных в ячейки в столбцах дата отправки
If IsEmpty(Cells(k, i + 1)) Or (IsDate(Cells(k, i + 1)) And Cells(k, i + 1) >= DateValue("01.04.2017")) And InStr(Cells(k, i + 1), " ") = 0 And InStr(Cells(k, i + 1), ",") = 0 Then
Cells(k, i + 1).Interior.Color = xlNone
Else
Cells(k, i + 1).Interior.Color = vbRed
ilastrow = Worksheets("ОШИБКИ").Cells(Rows.Count, 1).End(xlUp).Row + 1
ActiveSheet.Range("B" & k & ":K" & k).Copy Destination:=Worksheets("ОШИБКИ").Cells(ilastrow, 1)
Worksheets("ОШИБКИ").Cells(ilastrow, 11) = ActiveSheet.Cells(4, i + 1).Value
ActiveSheet.Cells(k, i + 1).Copy Destination:=Worksheets("ОШИБКИ").Cells(ilastrow, 12)
Worksheets("ОШИБКИ").Cells(ilastrow, 12).Hyperlinks.Delete
Worksheets("ОШИБКИ").Hyperlinks.Add Anchor:=Worksheets("ОШИБКИ").Cells(ilastrow, 12), Address:="", _
SubAddress:="'" & "отчет" & "'!" & ActiveSheet.Cells(k, i + 1).Address(0, 0), _
ScreenTip:="Перейти на: " & "отчет" & "!" & ActiveSheet.Cells(k, i + 1).Address(0, 0)
End If
'проверяем формат данных внесенных в ячейки в столбцах дата вручения
If IsEmpty(Cells(k, i + 2)) Or (IsDate(Cells(k, i + 2)) And Cells(k, i + 2) >= DateValue("01.04.2017")) And InStr(Cells(k, i + 2), " ") = 0 And InStr(Cells(k, i + 2), ",") = 0 Then
Cells(k, i + 2).Interior.Color = xlNone
Else
Cells(k, i + 2).Interior.Color = vbRed
ilastrow = Worksheets("ОШИБКИ").Cells(Rows.Count, 1).End(xlUp).Row + 1
ActiveSheet.Range("B" & k & ":K" & k).Copy Destination:=Worksheets("ОШИБКИ").Cells(ilastrow, 1)
Worksheets("ОШИБКИ").Cells(ilastrow, 11) = ActiveSheet.Cells(4, i + 2).Value
ActiveSheet.Cells(k, i + 2).Copy Destination:=Worksheets("ОШИБКИ").Cells(ilastrow, 12)
Worksheets("ОШИБКИ").Cells(ilastrow, 12).Hyperlinks.Delete
Worksheets("ОШИБКИ").Hyperlinks.Add Anchor:=Worksheets("ОШИБКИ").Cells(ilastrow, 12), Address:="", _
SubAddress:="'" & "отчет" & "'!" & ActiveSheet.Cells(k, i + 2).Address(0, 0), _
ScreenTip:="Перейти на: " & "отчет" & "!" & ActiveSheet.Cells(k, i + 2).Address(0, 0)
End If
'проверяем формат данных внесенных в ячейки оплата
If WorksheetFunction.IsNumber(Cells(k, i + 3)) Or IsEmpty(Cells(k, i + 3)) Then
Cells(k, i + 3).Interior.Color = xlNone
Else
Cells(k, i + 3).Interior.Color = vbRed
ilastrow = Worksheets("ОШИБКИ").Cells(Rows.Count, 1).End(xlUp).Row + 1
ActiveSheet.Range("B" & k & ":K" & k).Copy Destination:=Worksheets("ОШИБКИ").Cells(ilastrow, 1)
Worksheets("ОШИБКИ").Cells(ilastrow, 11) = ActiveSheet.Cells(4, i + 3).Value
ActiveSheet.Cells(k, i + 3).Copy Destination:=Worksheets("ОШИБКИ").Cells(ilastrow, 12)
Worksheets("ОШИБКИ").Cells(ilastrow, 12).Hyperlinks.Delete
Worksheets("ОШИБКИ").Hyperlinks.Add Anchor:=Worksheets("ОШИБКИ").Cells(ilastrow, 12), Address:="", _
SubAddress:="'" & "отчет" & "'!" & ActiveSheet.Cells(k, i + 3).Address(0, 0), _
ScreenTip:="Перейти на: " & "отчет" & "!" & ActiveSheet.Cells(k, i + 3).Address(0, 0)
End If
'
' проверяем формат данных внесенных в ячейки в столбцах дата оплаты
If IsEmpty(Cells(k, i + 4)) Or (IsDate(Cells(k, i + 4)) And Cells(k, i + 4) >= DateValue("01.04.2017")) And InStr(Cells(k, i + 4), " ") = 0 And InStr(Cells(k, i + 4), ",") = 0 Then
Cells(k, i + 4).Interior.Color = xlNone
Else
Cells(k, i + 4).Interior.Color = vbRed
ilastrow = Worksheets("ОШИБКИ").Cells(Rows.Count, 1).End(xlUp).Row + 1
ActiveSheet.Range("B" & k & ":K" & k).Copy Destination:=Worksheets("ОШИБКИ").Cells(ilastrow, 1)
Worksheets("ОШИБКИ").Cells(ilastrow, 11) = ActiveSheet.Cells(4, i + 4).Value
ActiveSheet.Cells(k, i + 4).Copy Destination:=Worksheets("ОШИБКИ").Cells(ilastrow, 12)
Worksheets("ОШИБКИ").Cells(ilastrow, 12).Hyperlinks.Delete
Worksheets("ОШИБКИ").Hyperlinks.Add Anchor:=Worksheets("ОШИБКИ").Cells(ilastrow, 12), Address:="", _
SubAddress:="'" & "отчет" & "'!" & ActiveSheet.Cells(k, i + 4).Address(0, 0), _
ScreenTip:="Перейти на: " & "отчет" & "!" & ActiveSheet.Cells(k, i + 4).Address(0, 0)
End If
'проверяем формат данных внесенных в ячейки в столбцах дата отправки претензии
If IsEmpty(Cells(k, i + 5)) Or (IsDate(Cells(k, i + 5)) And Cells(k, i + 5) >= DateValue("01.04.2017")) And InStr(Cells(k, i + 5), " ") = 0 And InStr(Cells(k, i + 5), ",") = 0 Then
Cells(k, i + 5).Interior.Color = xlNone
Else
Cells(k, i + 5).Interior.Color = vbRed
ilastrow = Worksheets("ОШИБКИ").Cells(Rows.Count, 1).End(xlUp).Row + 1
ActiveSheet.Range("B" & k & ":K" & k).Copy Destination:=Worksheets("ОШИБКИ").Cells(ilastrow, 1)
Worksheets("ОШИБКИ").Cells(ilastrow, 11) = ActiveSheet.Cells(4, i + 5).Value
ActiveSheet.Cells(k, i + 5).Copy Destination:=Worksheets("ОШИБКИ").Cells(ilastrow, 12)
Worksheets("ОШИБКИ").Cells(ilastrow, 12).Hyperlinks.Delete
Worksheets("ОШИБКИ").Hyperlinks.Add Anchor:=Worksheets("ОШИБКИ").Cells(ilastrow, 12), Address:="", _
SubAddress:="'" & "отчет" & "'!" & ActiveSheet.Cells(k, i + 5).Address(0, 0), _
ScreenTip:="Перейти на: " & "отчет" & "!" & ActiveSheet.Cells(k, i + 5).Address(0, 0)
End If
Next i
Next k
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Worksheets("ОШИБКИ").Activate
End Sub
|