행과 열의 교차 셀 강조 표시 VBA

Question

열 머리글의 텍스트가 행의 텍스트와 같고 행과 열의 교차 셀이 강조 표시되는 매크로를 기록하려고합니다. 예를 들어

:

A11: "description" 
Y1: "description" 
->Y11 should be highlighted 

Answer 1

그래서이 그것입니다. 내가 필요한 것을 완벽하게 작동

하위 BorderForNonEmpty2()

Dim wb As Workbook 
Dim wsCurrent As Worksheet 

With Application 
    .ScreenUpdating = False 
    .EnableEvents = False 
End With 

Set wb = ActiveWorkbook 
Set wsCurrent = wb.ActiveSheet 

Dim atLastCompareDate As Boolean 
Dim atLastMPDate As Boolean 
Dim mPDateCounter As Integer 
Dim compareDateCounter As Integer 
mPDateCounter = 3 

'loop over each row where the value in column c is not empty, starting at row 3 
Do While Not atLastMPDate 
    Dim mPDate As String 

    mPDate = wsCurrent.Range("C" + CStr(mPDateCounter)).Value 
    atLastCompareDate = False 
    If (mPDate = Null Or mPDate = "") Then 
     atLastMPDate = True 

    Else 
     'loop over each column where the value in row 1 is not empty, starting at column e 
     compareDateCounter = 5 
     Do While (Not atLastCompareDate) 
      Dim compareDate As String 
      Dim currentCellColumn As String 
      If (compareDateCounter <= 26) Then 
       currentCellColumn = Chr((compareDateCounter) + 96) 
      Else 
       If (compareDateCounter > 26) And (compareDateCounter Mod 26 = 0) Then 
        currentCellColumn = Chr(Int(compareDateCounter/26) - 1 + 96) + Chr(122) 
       Else 
        currentCellColumn = Chr(Int(compareDateCounter/26) + 96) + Chr((compareDateCounter Mod 26) + 96) 
       End If 
      End If 
      compareDate = wsCurrent.Range(currentCellColumn + CStr(1)).Value 
      If (compareDate = Null Or compareDate = "") Then 
       atLastCompareDate = True 
      Else 
       If (compareDate = mPDate) Then 
        Dim cellLocation As String 
        If (compareDateCounter <= 26) Then 
         cellLocation = Chr((compareDateCounter) + 96) 
        Else 
         If (compareDateCounter > 26) And (compareDateCounter Mod 26 = 0) Then 
          cellLocation = Chr(Int(compareDateCounter/26) - 1 + 96) + Chr(122) 
         Else 
          cellLocation = Chr(Int(compareDateCounter/26) + 96) + Chr((compareDateCounter Mod 26) + 96) 
         End If 
        End If 

        wsCurrent.Range(cellLocation + CStr(mPDateCounter)).Interior.ColorIndex = 11 

        'Loop backwards to mark the 6 dates before 
        Dim i As Integer 
        i = compareDateCounter - 1 
        Do While (i > compareDateCounter - 7) 
         If (i <= 26) Then 
          cellLocation = Chr((i) + 96) 
         Else 
          If (i > 26) And (i Mod 26 = 0) Then 
           cellLocation = Chr(Int(i/26) - 1 + 96) + Chr(122) 
          Else 
           cellLocation = Chr(Int(i/26) + 96) + Chr((i Mod 26) + 96) 
          End If 
         End If 
         wsCurrent.Range(cellLocation + CStr(mPDateCounter)).Interior.ColorIndex = 43 
         wsCurrent.Range(cellLocation + CStr(mPDateCounter)).Borders.LineStyle = xlContinuous 
         wsCurrent.Range(cellLocation + CStr(mPDateCounter)).Borders.ColorIndex = 11 

         i = i - 1 
        Loop 
        atLastCompareDate = True 
       End If 
      End If 
      compareDateCounter = compareDateCounter + 1 
     Loop 
    End If 
    mPDateCounter = mPDateCounter + 1 
Loop 

최종 하위이

Answer 2

당신의 대답은하지 않는 것 (또한 앞서 교차로에 하나의 세포의 숫자를 강조) 직관적으로 질문에 답하기 : 발견 된 일치 항목에서 교차하는 행과 열을 강조하는 방법?

본래의 접근법은 성냥을 찾기 위해 열과 행을 반복하는 것입니다 :

Private Sub ColorIntersection() 

    Application.EnableEvents = False 
    Application.ScreenUpdating = False 

    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1") 
    Dim cols As Range, rws As Range 
    Dim lastRow As Integer: lastRow = ws.UsedRange.Rows.Count 
    Dim lastColumn As Integer: lastColumn = ws.UsedRange.Columns.Count 

    For Each cols In ws.Range(ws.Cells(1, 1), ws.Cells(1, lastColumn)) 
     If (Not (cols.Value = vbNullString)) Then 
      For Each rws In ws.Range("A1:A" & lastRow) 
       If (rws.Value = cols.Value) Then ws.Cells(rws.Row, cols.Column).Interior.Color = 5296210 
      Next 
     End If 
    Next 

    Application.EnableEvents = True 
    Application.ScreenUpdating = True 

End Sub