CODEWITHSUNDEEP
excelvba
somashekar
somashekar

Reputation: 13

How to concatenate col and row headers in excel VBA based on cell values

I am trying to concatenate col and row headers based on the cell value. Sample data is added as below.

Sample data:
Sample data

Wherever cell value is '1' then row and col headers needs to be concatenated and written into a new worksheet. Sample result is as below. I am a beginner and still trying to learn so any help I can get is greatly appreciated.

Result:
Result

Upvotes: 1

Views: 403

Answers (2)

VBasic2008
VBasic2008

Reputation: 54777

Concatenate Row and Column Labels

  • This is a beginner-intermediate code and surely can be written more efficiently.
  • Adjust (play with) the values in the constants section.
  • It is assumed that the 'row labels column' and the 'column labels row' (headers) don't contain empty cells (because xlDown, xlToRight would fail).
Option Explicit

Sub concatHeaders()
    
    ' Source
    Const sName As String = "Sheet1"
    Const sFirst As String = "A1"
    Const sCriteria As Long = 1
    ' Destination
    Const dName As String = "Sheet2"
    Const dFirst As String = "A1"
    Const dHeader As String = "Result"
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    Dim srg As Range ' Source Range
    With wb.Worksheets(sName).Range(sFirst)
        Dim fRow As Long: fRow = .Row
        Dim lRow As Long: lRow = .End(xlDown).Row
        Dim fCol As Long: fCol = .Column
        Dim lCol As Long: lCol = .End(xlToRight).Column
        Set srg = .Resize(lRow - fRow + 1, lCol - fCol + 1)
        'Debug.Print srg.Address
    End With

    ' Destination
    Dim dCell  As Range: Set dCell = wb.Worksheets(dName).Range(dFirst)
    dCell.Value = dHeader ' write header
    
    ' Write
    Dim r As Long, c As Long
    For r = fRow + 1 To lRow
        For c = fCol + 1 To lCol
            If srg(r, c).Value = sCriteria Then
                Set dCell = dCell.Offset(1) ' next row
                dCell.Value = srg(r, 1).Value & srg(1, c).Value ' write
            End If
        Next c
    Next r
    
End Sub

Upvotes: 0

Harun24hr
Harun24hr

Reputation: 36770

If you want to go with formula then use FILTERXML() with TEXTJOIN().

=FILTERXML("<t><s>"&TEXTJOIN("</s><s>",TRUE,IF(B2:E5=1,A2:A5&B1:E1,""))&"</s></t>","//s")

enter image description here

Upvotes: 2

Related Questions