Проблема с частью моего кода - используется для построения таблицы - PullRequest
0 голосов
/ 05 ноября 2019

У меня есть код, который строит таблицу на основе данных в другом листе. На этом листе есть три столбца - Время, URN и Местоположение. Время отображается как ЧЧ: ММ: СС, URN - это четырехзначное число, а Location - это почтовый индекс, отображаемый в обычном формате.

Я обычно использовал этот код с датой вместо времени, но я пытался использовать его со временем. После внесения даты в переменную я внес небольшую корректировку, добавив часть значения времени.

Теперь я получаю

Ошибка времени выполнения '91': переменная объекта или переменная блока не установлена,

с выделением следующего:

.Cells(FndDt.Row, FndNum.Column) = "P"

Я попытался удалить этот кусок кода и добавить On Error Resume Next, но затем я получаю сообщение об ошибке в строках выше или ниже его.

Option Explicit

Sub chrisellis250()
Dim Dt, Urn, i As Long, x As Long, lr As Long, lc As Long: x = 2
Dim colwidth As Long
Dim FndDt As Range, FndNum As Range, Dat As Date, Num As String, Loc As String
Dat = TimeValue("00:00:00")
Application.ScreenUpdating = False
With Sheet2
    lr = .Cells(.Rows.Count, 2).End(xlUp).Row
    .Range(.Cells(2, 1), .Cells(.Rows.Count, 1)).AdvancedFilter xlFilterCopy, , .Range("E1"), True
    With .Range("E1").CurrentRegion:  Dt = .Value:  End With
    Sheet1.Range("A3").Resize(UBound(Dt) - 1) = .Range("E2:E" & UBound(Dt)).Value: .Columns(5).Clear
    Sheet1.Range("A3").Resize(UBound(Dt) - 1).Interior.ColorIndex = 15
    .Range(.Cells(2, 2), .Cells(.Rows.Count, 2)).AdvancedFilter xlFilterCopy, , .Range("E1"), True
    With .Range("E1").CurrentRegion: Urn = .Value: End With
    For i = 1 To 2
        Sheet1.Cells(2, x).Resize(, UBound(Urn) - 1) = Application.WorksheetFunction.Transpose(.Range("E2:E" & UBound(Urn)).Value)
        If i = 1 Then colwidth = 8.3 Else colwidth = 55
        Sheet1.Cells(2, x).Resize(, UBound(Urn) - 1).ColumnWidth = colwidth
        If x = 2 Then Sheet1.Cells(1, x) = "URN" Else Sheet1.Cells(1, x) = "XXXXX"
        Sheet1.Cells(1, x).Resize(, UBound(Urn) - 1).MergeCells = True
        Sheet1.Cells(1, x).Resize(, UBound(Urn) - 1).Interior.ColorIndex = 15
        x = x + UBound(Urn) - 1
    Next i
    .Columns(5).Clear
    For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
        If .Range("B" & i) <> "" Then
            Dat = .Range("A" & i): Num = .Range("B" & i): Loc = .Range("C" & i)
            With Sheet1
                .Range("B3").Resize(lr, UBound(Urn) - 1).Font.Name = "Wingdings 2"
                lc = .Cells(2, .Columns.Count).End(xlToLeft).Column
                Set FndDt = .Range("A:A").Find(Dat, LookIn:=xlValues, lookat:=xlWhole)
                Set FndNum = .Range(.Cells(2, 1), .Cells(2, lc)).Find(Num, LookIn:=xlValues, lookat:=xlWhole)
                .Cells(FndDt.Row, FndNum.Column) = "P": .Cells(FndDt.Row, FndNum.Column).Font.Color = vbGreen
                On Error Resume Next
                If Not .Cells(FndDt.Row, FndNum.Column + UBound(Urn) - 1) Like "*" & Loc & "*" Then
                 .Cells(FndDt.Row, FndNum.Column + UBound(Urn) - 1) = IIf(.Cells(FndDt.Row, FndNum.Column + UBound(Urn) - 1) = "", Loc, .Cells(FndDt.Row, FndNum.Column + UBound(Urn) - 1) & "," & Loc)
             End If
             End With
        End If
    Next i
    With Sheet1
        With .Range("B3").Resize(UBound(Dt) - 1, UBound(Urn) - 1)
            .SpecialCells(xlCellTypeBlanks).Font.Color = vbRed: .SpecialCells(xlCellTypeBlanks).Value = "O":
        End With
        With .Range("B3").Offset(, UBound(Urn) - 1).Resize(UBound(Urn) - 1, UBound(Urn) - 1)
            .SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = 15
        End With
        AddOutsideBorders .Range("A1").Resize(UBound(Dt) + 1, 1 + ((UBound(Urn) - 1) * 2))
        With .Cells
            .Columns.AutoFit
            .HorizontalAlignment = xlCenter
            .RowHeight = 25
        End With
    End With
End With
Application.ScreenUpdating = True
End Sub

Public Function AddOutsideBorders(rng As Range)
With rng.Borders
    .LineStyle = xlContinuous
    .Color = vbBlack
    .Weight = xlThin
End With
End Function
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...