如何根據“Y”或“N”輸入轉置一行中的特定單元格值

Question

最終目標是將特定行的狀態設置為“是”，並將以紅色突出顯示的行的數據自動輸入到另一張表中，以便以 Zlabel 打印機所需的格式打印。

如果您可以想象這些原始數據的規模更大，並且每天必須打印 50 多行。 我現在手動執行此操作，但真的希望簡化此過程

這就是我希望當狀態設置為“是”時數據將在單獨的工作表上顯示的方式，無論我可以批量打印多少行

對可能包括 VBA 宏或任何其他推薦解決方案的任何其他建議持開放態度。

非常感謝任何建議或幫助！

Answer 1

嘗試，

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

按條件復制

• 當Source的Criteria Column （“ I ”）中有任何數據時，以下自動清除Target Worksheet （“ Sheet2 ”）的內容並將Crit （“ Yes ”）指定的所有數據復制到它（“ Sheet2 ”）工作表（“ Sheet1 ”）是手動更改的（即可以編寫它以更有效地運行）。
• 如果您不希望它自動運行，則從工作表模塊中刪除代碼，並在需要時運行第一個Sub （可能使用按鈕）（這是我的第一個想法）。
• 您可以更改tgtGap ，即數據塊之間的行數。
• 您可以向Cols數組添加或刪除列。

標准模塊，例如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

工作表模塊，例如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

如果您有 Excel O365，那么您也可以選擇公式。 如果您的數據必須從Sheet2!A1開始，然后在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)),"")

拖累。