Добавление границы ячейки на основе значения 2 ячеек в диапазоне

Question

Я хочу сделать отчет довольно для искажения.В столбце A есть даты, а в столбце C.до последнего ряда в этой группировке.Есть много групп переменной длины.Пока у меня есть код ниже, и я вставил то, что я ищу.Любая помощь приветствуется.

Спасибо !!

    Function ExCap(Rng As Range)
    Application.Volatile
    ExCap = ""
    For f = 1 To Len(Rng)
    If Asc(Mid(Rng.Value, f, 1)) >= 65 And Asc(Mid(Rng.Value, f, 1)) <= 90 Then
    ExCap = ExCap & Mid(Rng.Value, f, 1)
    End If
    Next f
    End Function
    Function GetColumnLetter(colNum As Long) As String
        Dim vARR
        vARR = Split(Cells(1, colNum).Address(True, False), "")
        GetColumnLetter = vARR(0)
    End Function
    Function funcCreateList(argCreateList)
        For Each Worksheet In ThisWorkbook.Worksheets
            If argCreateList = Worksheet.Name Then
                Exit Function ' if found - exit function
            End If
        Next Worksheet
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = argCreateList
    End Function
    Function InCom(s As String)
        Dim i As Long
        Dim result As String

    If s = "" Then Exit Function

        For i = 1 To Len(s) Step 2
            On Error Resume Next
            result = result & Left(s, 2) & ", "
            s = Mid(s, 3, Len(s) - 2)
        Next i

        InCom = Left(result, Len(result) - 2)
    End Function
    Function IsFileOpen(FileName As String)
    Dim iFilenum As Long
    Dim iErr As Long

    On Error Resume Next
    iFilenum = FreeFile()
    Open FileName For Input Lock Read As #iFilenum
    Close iFilenum
    iErr = Err
    On Error GoTo 0

    Select Case iErr
    Case 0: IsFileOpen = False
    Case 70: IsFileOpen = True
    Case Else: Error iErr
    End Select
    End Function



    Sub Weekly_Report()
    Dim wrpath As String, wmr As Workbook, wtd As Workbook, wed As [enter image description here][1]Workbook, ws1 As Worksheet
    Dim LastRow As Long, myCol As String, LastCol As Long, Rng As Range, Piv As Worksheet


    Application.ScreenUpdating = False


    wrpath = "c:\mypathtoaraise”

    ChDir (wrpath)

    If IsFileOpen(wrpath & "wmr.xls") = 0 Then
    Workbooks.Open (wrpath & "wmr.xls")
    Else
    Workbooks("wmr.xls").Activate
    End If

    Set wmr = Workbooks("wmrxls")
    Set ws1 = Sheets("Sheet1")
    LastRow = ws1.Range("A" & Rows.Count).End(xlUp).Row


    Do Until LastRow = 1
        Set Rng = Range("C" & LastRow)
        Range("J" & LastRow) = InCom(ExCap(Rng))
        Rng.Value = Range("J" & LastRow).Value

        Set Rng = Range("G" & LastRow)
        Range("K" & LastRow) = InCom(ExCap(Rng))
        Rng.Value = Range("K" & LastRow).Value

        LastRow = LastRow - 1
    Loop

    Range("J:K").ClearContents

    LastRow = ws1.Range("A" & Rows.Count).End(xlUp).Row
    LastCol = ws1.Range("A1").CurrentRegion.Columns.Count
    myCol = GetColumnLetter(LastCol)

    Rows("2:" & LastRow).Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B2:B" & LastRow) _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With ActiveWorkbook.Worksheets("Sheet1").Sort
            .SetRange Range("A2:" & myCol & LastRow)
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    Range("A2").Select

    Columns("B:B").Select
    Selection.Cut
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight
    Range("A2").Select

Answer 1

кода пока нет, но я по умолчанию установлю границу xlbottom, а затем сделаю 2, если затем проверю, чтобы удалить границу и добавить ее в следующий диапазон

Отредактировано с кодом:

FirstRow = FirstRow + 1
Set pdRng = Range("A" & FirstRow - 1)
Set piRng = Range("C" & FirstRow - 1)
Do Until FirstRow = LastRow + 1
    Set dRng = Range("A" & FirstRow)
    Set iRng = Range("C" & FirstRow)
    If dRng <> pdRng Or iRng <> piRng Then
        Range("A" & FirstRow & ":I" & FirstRow).Borders(xlEdgeBottom).LineStyle = xlContinuous
        FirstRow = FirstRow + 1
        Set pdRng = Range("A" & FirstRow - 1)
        Set piRng = Range("C" & FirstRow - 1)
    Else
        dRng.ClearContents
        Range("A" & FirstRow & ":I" & FirstRow).Borders(xlEdgeTop).LineStyle = xlNone
        Range("A" & FirstRow & ":I" & FirstRow).Borders(xlEdgeBottom).LineStyle = xlContinuous
        FirstRow = FirstRow + 1
        Set piRng = Range("C" & FirstRow - 1)
    End If
Loop

Использование следующей функции для FirstRow:

FirstRow = IIf(IsEmpty(Sheets("Sheet1").Range("B1")), Sheets("Sheet1").Range("B1").End(xlDown).Row, 1)