仅选择值为VBA的单元格

我有下面的代码，工作正常，但我只想复制带有值的单元格。我在中间有空白数据，因为我会删除复制它们也是没有意义的。

Sub FindAgain()
'
' FindAgain Macro
'
    Dim Ws As Worksheet
    Dim LastRow As Long

    AC = ActiveCell.Column
    Set Ws = Worksheets("Sheet1")
    LastRow = Ws.Cells(Rows.Count, "B").End(xlUp).Row
    Cells.Find(What:="Scenario", After:=ActiveCell, LookIn:=xlValues, LookAt _
        :=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
    ActiveCell.Offset(1, 0).Select
    Range(ActiveCell, Cells(LastRow, AC)).Select

End Sub

---

你知道我怎样才能写得更好吗？也许是用Loop？谢谢

我假设在

范围（ActiveCell，Cells（LastRow，AC））之后。选择
您将看到要复制的区域，忽略空白单元格。一种方法是迭代选择中的所有单元格，检查它们是否为空并复制它们：

Dim c As Range
Dim i As Long

' store current row for every column separately
Dim arrRowInCol() As Long
ReDim arrRowInCol(Selection.Column To Selection.Column + Selection.Columns.Count - 1)
For i = LBound(arrRowInCol) To UBound(arrRowInCol)
    ' init the first row for each column
    arrRowInCol(i) = Selection.Row
Next i

For Each c In Selection
    If Len(Trim(c)) <> 0 Then
        c.Copy Destination:=Sheets("Sheet2").Cells(arrRowInCol(c.Column), c.Column)
        arrRowInCol(c.Column) = arrRowInCol(c.Column) + 1
    End If
Next c

尺寸c作为范围
我想我会坚持多久
'分别存储每列的当前行
Dim arrRowInCol（）的长度与
ReDim arrRowInCol（Selection.Column到Selection.Column+Selection.Columns.Count-1）
对于i=LBound（arrRowInCol）到UBound（arrRowInCol）
'初始化每列的第一行
arrRowInCol（i）=选择。行
接下来我
对于选择中的每个c
如果Len（Trim（c））为0，则
c、 复制目的地：=纸张（“纸张2”）.单元格（arrRowInCol（c列），c列）
arrRowInCol（c.列）=arrRowInCol（c.列）+1
如果结束
下一个c
我将从您的代码开始，它实际上尝试选择范围。这就是我在此基础上建立的：

Option Explicit

Public Sub FindMe()

    Dim my_range            As Range
    Dim temp_range          As Range

    Dim l_counter           As Long
    Dim my_list             As Object
    Dim l_counter_start     As Long


    Set my_list = New Collection

    l_counter_start = Cells.Find(What:="Scenario", After:=ActiveCell, LookIn:=xlValues, LookAt _
        :=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Row + 1

    For l_counter = l_counter_start To Worksheets("sheet1").Cells(Rows.Count, "B").End(xlUp).Row
        If Cells(l_counter, 2) <> "" Then my_list.Add (l_counter)
    Next l_counter

    For l_counter = 1 To my_list.Count
        Set temp_range = Range(Cells(my_list(l_counter), 2), Cells(my_list(l_counter), 4))

        If my_range Is Nothing Then
            Set my_range = temp_range
        Else
            Set my_range = Union(my_range, temp_range)
        End If
    Next l_counter

    my_range.Select

End Sub

选项显式
公共次级金融机构（）
将我的_范围变暗为范围
变暗温度范围作为范围
调暗l_计数器的长度
将我的_列表设置为对象
调暗l\u计数器\u启动时间尽可能长
设置我的收藏列表=新收藏
l_counter_start=Cells.Find（What:=“Scenario”，After:=ActiveCell，LookIn:=xlValues，LookAt_
：=xlPart，SearchOrder:=xlByColumns，SearchDirection:=xlNext，MatchCase:=_
False，SearchFormat:=False）。行+1
对于l_counter=l_counter_，开始工作表（“sheet1”）。单元格（Rows.Count，“B”）。结束（xlUp）。行
如果单元格（l_计数器，2）“，则my_list.Add（l_计数器）
下一个l_计数器
对于l_counter=1到我的_list.Count
设置温度范围=范围（单元格（我的列表（l\u计数器），2），单元格（我的列表（l\u计数器），4））
如果我的_范围为零，那么
设置我的温度范围=温度范围
其他的
设置my_range=联合（my_range，temp_range）
如果结束
下一个l_计数器
my_range.Select
端接头

它适用于以下情况：

它的工作原理大致如下：


我们宣布两个范围
范围
my_range
是最后要选择的范围
仅当第二列中有值时，才会给出范围
temp\u range
然后是两个范围的并集，并在代码末尾选择
my_range
找到了一种方法来做我想做的事：至少是工作，我是新手，所以，对你们来说可能看起来很有趣或不好，对我来说是很棒的=D

Sub FindAgain()
'
' FindAgain Macro
'
Dim Ws As Worksheet
Dim LastRow As Long
Dim c As Range
Dim i As Integer
Dim j As Integer

AC = ActiveCell.Column
Set Ws = Worksheets("Sheet1")
LastRow = Ws.Cells(Rows.Count, "B").End(xlUp).Row
i = 15
j = 7
Cells.Find(What:="Scenario", After:=ActiveCell, LookIn:=xlValues, LookAt _
        :=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
ActiveCell.Offset(1, 0).Select
Range(ActiveCell, Cells(LastRow, AC)).Select

For Each c In Selection
    If Len(Trim(c)) <> "" Then
        c.Copy Destination:=Sheets("Sheet1").Cells(i, j)
    End If

    If c = "" Then
    i = i
    Else
    i = i + 1
    End If
    j = j

Next c

End Sub

Sub FindAgain（）
'
“FindAgain宏
'
将Ws设置为工作表
最后一排一样长
调光范围
作为整数的Dim i
作为整数的Dim j
AC=ActiveCell.Column
设置Ws=工作表（“表1”）
LastRow=Ws.Cells（Rows.Count，“B”）.End（xlUp）.Row
i=15
j=7
查找（What:=“Scenario”，After:=ActiveCell，LookIn:=xlValues，LookAt_
：=xlPart，SearchOrder:=xlByColumns，SearchDirection:=xlNext，MatchCase:=_
False，SearchFormat:=False）。激活
ActiveCell.Offset（1，0）。选择
范围（ActiveCell，单元格（LastRow，AC））。选择
对于选择中的每个c
如果Len（Trim（c））”“那么
c、 复制目的地：=纸张（“纸张1”）。单元格（i，j）
如果结束
如果c=”“，则
i=i
其他的
i=i+1
如果结束
j=j
下一个c
端接头
您是否看过：或者两者都显示了您可以使用的示例。我认为这会有所帮助！我可能没有正确检查。这与我想要的非常接近。你的作品发生的是，当它再次发生时，空行保持在下面，因为数据又在空白的下面。比如说，它保持1空白4空白5，我想要的是将数据粘贴在彼此下面1 4 5 etcI已经更新了代码，分别存储每列的当前行。只有在粘贴时才增加它-因此它有效地折叠空值上的每一列。看看这是否有效。