Проверить ячейки на соответствие заданным форматам и создать список несоответствующих ячеек с гиперссылкой на них с помощью VBA.

RSS

Mershik

Пользователь

Сообщений: 8277 Регистрация: 03.12.2015

20.04.2020 14:08:41

Всем доброго времени суток!
Прошу Вас помочь.
Ежедневно от 10 до 30 раз обновляются данные в таблице Range("O5:" последний столбец (определяется как ячейка со словом Реализация в строке 2 - 1 & последняя строка) количество строк и столбцов всегда разное, но всегда именно так определяется.
Этот диапазон состоит всегда из одинаковых значений по формату: число, дата, дата, число, дата, дата.
Так как данные вносятся людьми бывают некорректные данные а именно ..дата как текст или не существующая дата (31.11.2019) или 31 01 2019, Даты не должны быть меньше чем 01.04.2017 (дата создания организации) и не больше чем сегодня(), ячейки с суммами могут через точку писать или вообще не ставить ничего (пробел)...Проверив все ячейки нужно вывести список на отдельный лист с ошибкам и ссылками на них.

Макрос я сделал но так как данных для проверки очень долго работает не быстро (секунд 30), а хотел попробовать впихнуть его в массивы и не знаю как...

КОРОТКО НУЖНО ДИНАМИЧЕСКИЙ ДИАПАЗОН ПРОВЕРИТЬ ЧТО БЫ ТАМ БЫЛА ДАТА ИЛИ ЧИСЛО И МАКСИМАЛЬНО БЫСТРО. МНЕ КАЖЕТСЯ МАССИВЫ МОГУТ ТУТ ПОМОЧЬ - НО Я НЕ ЗНАЮ ИХ. ИЛИ ВОЗМОЖНО ПРОСТО УСКОРИТЬ РАБОТУ ТЕКУЩЕГО МАКРОСА...

а забыл - желаемый результат будет если нажать на кнопку на листе.

Код

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

Прикрепленные файлы

для форума.xlsb (43.09 КБ)

Изменено: Mershik - 20.04.2020 14:22:52

Не бойтесь совершенства. Вам его не достичь.

RAN

Пользователь

Сообщений: 7207 Регистрация: 21.12.2012

20.04.2020 16:31:26

Код

Sub Hyper()
    Dim ar, ar2(), x
    Dim i&, j&, ilastrow&, ilastcolumn&
    Dim col As New Collection
    ilastrow = Sheets("отчет").Cells(Sheets("отчет").Rows.Count, 1).End(xlUp).Row
    ilastcolumn = Sheets("отчет").Rows(2).Find("Реализация", LookIn:=xlValues).Column - 1
    ar = Sheets("отчет").Range("O4").Resize(ilastrow - 4, ilastcolumn - 14).Value
    For i = 2 To UBound(ar)
        For j = 1 To UBound(ar, 2)
            If Len(ar(i, j)) Then
                If InStr(1, ar(1, j), "дата", vbTextCompare) > 0 Then
                    If IsDate(ar(i, j)) Then
                        If ar(i, j) < CDate("01.04.2017") Or ar(i, j) > Date Then
                            col.Add (Cells(i + 3, j + 14).Address)
                        End If
                    Else
                        col.Add (Cells(i + 3, j + 14).Address)
                    End If
                Else
                    If Not IsNumeric(ar(i, j)) Then
                        col.Add (Cells(i + 3, j + 14).Address)
                    End If
                End If
            End If
        Next
    Next
    If col.Count Then
        i = 0
        ReDim ar2(1 To col.Count, 1 To 1)
        For Each x In col
            i = i + 1
            ar2(i, 1) = x
        Next
        Sheets("ОШИБКИ").Columns("A").Clear
        Sheets("ОШИБКИ").Range("A1").Resize(UBound(ar2)).Value = ar2
    End If
End Sub

В модуль листа ОШИБКИ

Код

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Column = 1 Then
        On Error Resume Next
        ThisWorkbook.FollowHyperlink Address:=ThisWorkbook.Name, SubAddress:="отчет!" & Target.Value
    End If
End Sub

Mershik Пользователь Сообщений: 8277 Регистрация: 03.12.2015	#3 20.04.2020 16:32:56 RAN, спасибо большое...сейчас буду пробовать на реальном файле... Как же мне вникнуть в эти Массивы..эх Не бойтесь совершенства. Вам его не достичь.