How to transpose specific cell values in a row based on “Y” or “N” input

Question

The ultimate goal is to set the status of a particular row to "Yes" and have the data of that row that is highlighted RED automatically be entered into another sheet in order to be printed in a format required for a Zlabel printer.

If you can imagine this raw data on a larger scale and having to print 50+ rows daily. I do this manually now but really hoping to streamline this process

This is how I'm hoping the data will look on a separate sheet when the status is set to "Yes" regardless of how many rows there are I could print in bulk

Open to any other suggestions that may include VBA macros or any other recommended solutions.

Any advice or help is extremely appreciated!

Answer 1

Try,

Sub test()
    Dim Ws As Worksheet, toWs As Worksheet
    Dim vDB, vR()
    Dim i As Long, n As Long, r As Long
    
    Set Ws = Sheets(1) 'Data sheet
    Set toWs = Sheets(2)  'Result sheet
    
    vDB = Ws.Range("a1").CurrentRegion
    
    r = UBound(vDB, 1)
    
    For i = 1 To r
        If vDB(i, 9) = "Yes" Then
            n = n + 5
            ReDim Preserve vR(1 To n)
            vR(n - 4) = vDB(i, 1)
            vR(n - 3) = vDB(i, 4)
            vR(n - 2) = vDB(i, 5)
            vR(n - 1) = vDB(i, 7)
        End If
    Next i
    
    With toWs
        .UsedRange = Empty
        .Range("a1").Resize(n) = WorksheetFunction.Transpose(vR)
    End With
End Sub

Answer 2

Copy By Criteria

• The following automatically clears the contents of the Target Worksheet (" Sheet2 ") and copies all data specified by Crit (" Yes ") to it (" Sheet2 "), when any data in the Criteria Column (" I ") of the Source Worksheet (" Sheet1 ") is manually changed (ie it could be written to run more efficiently).
• If you don't want it to run automatically, then remove the code from the Sheet Module and just run the first Sub (maybe using a button) when needed (which was my first idea).
• You can change tgtGap , the number of rows in between data blocks.
• You can add or remove columns to the Cols array.

Standard Module eg Module1

Option Explicit

Public Const CriteriaColumn As Variant = "I"  ' e.g. "A" or 1

Sub copyByCriteria()
    
    ' Source
    Const srcName As String = "Sheet1"
    Const FirstRow As Long = 2
    Const Crit As String = "Yes"
    Dim Cols As Variant: Cols = Array("A", "D", "E", "G") ' or 1, 4, 5, 7
    ' Target
    Const tgtName As String = "Sheet2"
    Const tgtFirstCell As String = "A1"
    Const tgtGap As Long = 1
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Collect data from Source Worksheet.
    Dim ws As Worksheet: Set ws = wb.Worksheets(srcName)
    Dim Criteria As Variant
    getColumn Criteria, ws, CriteriaColumn, FirstRow
    If IsEmpty(Criteria) Then Exit Sub
    Dim ubC As Long: ubC = UBound(Criteria)
    Dim ubD As Long: ubD = UBound(Cols)
    Dim Data As Variant: ReDim Data(ubD)
    Dim j As Long
    For j = 0 To ubD
        Data(j) = ws.Cells(FirstRow, Cols(j)).Resize(ubC)
    Next j
    Dim critCount As Long
    critCount = Application.WorksheetFunction _
                           .CountIf(ws.Columns(CriteriaColumn), Crit)
    
    ' Write data from Data Arrays to Target Array.
    Dim Target As Variant, i As Long, k As Long
    ReDim Target(1 To critCount * (ubD + 1 + tgtGap) - tgtGap, 1 To 1)
    For i = 1 To ubC
        If Criteria(i, 1) = Crit Then
            For j = 0 To ubD
                k = k + 1
                Target(k, 1) = Data(j)(i, 1)
            Next j
            k = k + tgtGap
        End If
    Next i
    
    ' Write Target Array to Target Worksheet.
    Set ws = wb.Worksheets(tgtName)
    ws.Cells.ClearContents
    ws.Range(tgtFirstCell).Resize(UBound(Target)).Value = Target
    
End Sub

Sub getColumn(ByRef Data As Variant, _
              Sheet As Worksheet, _
              Optional aColumn As Variant = 1, _
              Optional FirstRow As Long = 1)

    Dim rng As Range
    Set rng = Sheet.Columns(aColumn).Find("*", , xlValues, , , xlPrevious)
    If rng Is Nothing Then Exit Sub
    If rng.Row < FirstRow Then Exit Sub
    If rng.Row > FirstRow Then
        Data = Sheet.Range(Sheet.Cells(FirstRow, aColumn), rng).Value
    Else
        ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rng.Value
    End If
    
End Sub

Sheet Module eg Sheet1

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Me.Columns(CriteriaColumn)) Is Nothing Then
        copyByCriteria
    End If
End Sub

Answer 3

If you have Excel O365, then you could also opt for a formula. If your data has to start in Sheet2!A1 onwards then in A1 :

=IF(MOD(ROW(),5)>0,INDEX(INDEX(FILTER(Sheet1!A:H,Sheet1!I:I="Yes"),SEQUENCE(COUNTIF(Sheet1!I:I,"Yes")),{1;4;5;7}),ROUNDUP(ROW()/5,0),MOD(ROW(),5)),"")

Drag down.