[英]Adding Cell border based on value of 2 cells in a range
我正在寻找一份易于处理的报告。 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
尚无代码,但我将默认边框为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)
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.