excel - 扫描列中的变量并选择行

Question

我有一个很大的数据表，我需要一个代码来扫描列(屏幕截图“选择”)以查找 x 或添加复选框。如果有 x，则应选择该行，并且应将某些列转置到新表中。

我有一个代码来扫描列中的 x 并有代码来转置我需要的列，但我需要一些帮助来将这些代码组合在一起。

1. 扫描列(选择)中的 x 并选择行
2. 将所选行的一些单元格(所选列)转置到新表格中(我有代码)

For Each c In Range("K:K")
 ' If c.Value = "x" Then
  
  ' MsgBox "x found at " & c.Address
  'End If
'Next c

Sub TransposeColumn2Row()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim Myarray() As Variant
Dim LastRow As Integer, LastColumn As Integer
Dim StartCell As Range
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
Dim i As Long
Dim j As Long

Set StartCell = ws1.Range("A1")
LastRow = ws1.Cells(ws1.Rows.Count, StartCell.Column).End(xlUp).Row
LastColumn = ws1.Cells(StartCell.Row, ws1.Columns.Count).End(xlToLeft).Column

'copy specific columns into worksheet 2

j = 1
For i = 1 To LastColumn Step 1
    Select Case i
        Case 1, 4, 8, 6, 9, 3, 5 'target columns to copy
            With ws1
                Myarray() = .Range(.Cells(1, i), .Cells(LastRow, i)).Value
            End With
            
            With ws2
                .Range(.Cells(j, 1), .Cells(j, LastRow)) = Application.WorksheetFunction.Transpose(Myarray())
            End With
            j = j + 1
        Case Else
    End Select
Next i
    
Erase Myarray()

End Sub

帮我合并这些代码 提前谢谢

Answer 1

如果这是一项一次性任务，我会使用一个公式:

=TRANSPOSE(FILTER(FILTER(A:J, {1,0,1,1,1,1,0,1,1,0}), K:K="x"))

确切的表示法取决于本地设置(在我的例子中，公式看起来不同)。但这个可以与 VBA 中的 Evaluate 一起使用。在这里，我们使用数组 {1,0,1,1,1,1,0,1,1,0} 标记要复制的列，然后使用 "x"< 过滤行 在 K 列中。

对于 VBA，一般情况下使用 ListObject 会更容易解决这种情况。但我们也可以将感兴趣的列与标记的行相交并.Copy toDestination:

Sub CopyMarked()
Dim Source As Worksheet
Dim Destination As Worksheet
Dim Data As Range
Dim Criteria As Range
    Set Source = ActiveSheet
    Set Destination = Worksheets.Add(After:=Source)
    Set Data = Source.Range("A:A, C:F, H:I")       ' columns 1,4,8,6,9,3,5
    Set Criteria = Source.Columns("K").SpecialCells(xlCellTypeConstants).EntireRow
    Intersect(Data, Criteria).Copy 
    Destination.Range("a1").PasteSpecial xlPasteValues, Transpose:=True
End Sub