Question

我希望报道非常好的报道。列A中有日期，列C中有首字母。如果一组行的日期相同，例如01/01/1901，并且同一行的首字母相同，我想添加边框到这个分组的最后一行。有许多可变长度的分组。到目前为止我有以下代码，我也粘贴了我正在寻找的内容。任何帮助表示赞赏。

谢谢！

    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)

基于范围中的2个单元格的值添加单元格边框

1 个答案: