求助：VBA循环检测单元格值并转置数据功能实现（代码故障）

首先我得先指出你原代码里的几个小问题，这样你能明白为啥之前跑不通：

• 你定义了Needed_range作为B列的最后一行行号，但For Each cell In Range(Needed_range)这个写法不对——Range()需要的是一个单元格范围（比如Range("B1:B10")），而不是单独一个行号数字，所以这里得改成Range("B1:B" & Needed_range)才能遍历B列的所有数据行。
• 你用Exit Sub会在找到第一个1之后就直接结束程序，这样没法收集所有符合条件的A列值，得把这个去掉，换成收集值的逻辑。

下面是完整的修正代码，我给你加了详细注释，每一步都讲清楚：

Sub CollectAndTranspose()
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim lastRow As Long
    Dim cell As Range
    Dim collectedValues As Variant
    Dim count As Integer
    
    ' 设置源工作表（就是你要检测B列的那个表），可以改成你的表名，比如Sheet1
    Set wsSource = ThisWorkbook.Worksheets("Sheet1")
    ' 设置目标工作表（要转置数据的表），比如Sheet2
    Set wsTarget = ThisWorkbook.Worksheets("Sheet2")
    
    ' 获取B列最后一行的行号
    lastRow = wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).Row
    
    ' 初始化计数器，用来记录收集到的数值数量
    count = 0
    ' 先把数组设为能容纳最多可能的行数（避免后续动态调整的麻烦）
    ReDim collectedValues(1 To lastRow)
    
    ' 遍历B列的所有数据行
    For Each cell In wsSource.Range("B1:B" & lastRow)
        ' 检测当前单元格是否等于1（注意如果是数值型的1，直接用=1就行；如果是文本型的1要改成cell = "1"）
        If cell.Value = 1 Then
            count = count + 1
            ' 把相邻A列的值存入数组
            collectedValues(count) = wsSource.Cells(cell.Row, "A").Value
        End If
    Next cell
    
    ' 如果收集到了数据，就转置到目标工作表
    If count > 0 Then
        ' 重新调整数组大小，只保留实际收集到的元素
        ReDim Preserve collectedValues(1 To count)
        ' 把数组转置后写入目标工作表的A1开始的位置（你可以改成其他位置，比如C3）
        wsTarget.Range("A1").Resize(count, 1).Value = Application.Transpose(collectedValues)
        MsgBox "已成功收集并转置" & count & "个符合条件的值！"
    Else
        MsgBox "B列中没有找到数值1哦！"
    End If
End Sub

几个关键细节说明： #

• 我特意用了wsSource和wsTarget来明确指定工作表，这样避免因为当前活动表变化导致的错误，你只需要把括号里的表名改成你实际用的就行。
• 用数组来存储收集到的A列值，比逐个写入单元格效率高很多，尤其是数据量大的时候。
• 最后用Application.Transpose把一维数组转置成列写入目标表，完美实现你要的转置需求。
• 加了判断如果没有找到1的提示，更友好。

你可以直接把这段代码复制到你的VBA编辑器里，调整工作表名后运行试试，应该就能实现你想要的功能啦！

内容的提问来源于stack exchange，提问作者Maverick