循环遍历范围，如果单元格包含值，则复制到列中的下一个空单元格

Posted 2023-02-25

【中文标题】循环遍历范围，如果单元格包含值，则复制到列中的下一个空单元格

【英文标题】：Loop through range and if cell contains value copy to next empty cell in column

【发布时间】：2018-08-12 03:27:42

【问题描述】：

我很难找到任何有我的疑问的东西。我可以找到我需要的不同部分，但无法将它们放在一起。

我需要做的是查看一个设定范围，如果值在 0.001 和 0.26 之间，那么 复制单元格并粘贴到列（“DA”）中的下一个空单元格中，还从找到值的同一行复制单元格，但从列（“C”）复制并粘贴到列（“DB”）旁边。

我知道我必须使用 If 语句循环，并且当它找到与条件匹配时必须偏移单元格。但我不能把它放在一起。

我已经尝试了以下代码。

Sub COPYcell()
    Dim Last As Long
    Dim i As Long, unionRng As Range

    Last = 61
    Dim lastrow As Long
    lastrow = Sheets("Sheet1").Range("DA100").End(xlUp).Row

    For i = 5 To Last
        If (.Cells(i, "J").Value) >= 0.01 And (.Cells(i, "J").Value) <= 0.26 Then
          
           'Cells(i, "DA").Value = Cells(i, "J").Value
           Range(i, "J").Copy = Range("DA" & lastrow)
           Cells(i, "J").Offset(, -8) = Range("DB" & lastrow)
           Range("DC" & lastrow) = "July"
                         
         End If
    Next i                          
End Sub

【问题讨论】：

你不是说

如果我认为你需要说 lastrow=lastrow+1 ，否则你会继续覆盖自己。

感谢您回复 Jeremy Kahan，我不确定您所说的 +1 是什么意思。我当前的代码不起作用，不知道为什么。你能帮忙吗？

【参考方案1】：

尝试以下方法：

Option Explicit    
Public Sub COPYcell()
    Dim last As Long, sht1 As Worksheet
    Dim i As Long, unionRng As Range, lastrow As Long, nextRow
    Application.ScreenUpdating = False
    Set sht1 = Worksheets("Sheet1")
    last = 61

    With sht1
        lastrow = .Cells(.Rows.Count, "DA").End(xlUp).Row
        nextRow = IIf(lastrow = 1, 1, lastrow + 1)
        For i = 5 To last
            If .Cells(i, "J").Value >= 0.01 And .Cells(i, "J").Value <= 0.26 Then '1%=26%
                If Not unionRng Is Nothing Then
                    Set unionRng = Union(unionRng, .Cells(i, "J"))
                Else
                    Set unionRng = .Cells(i, "J")
                End If
            End If
        Next i

        If Not unionRng Is Nothing Then
            unionRng.Copy .Range("DA" & nextRow)
            unionRng.Offset(0, -7).Copy .Range("DB" & nextRow)
        End If
    End With
    Application.ScreenUpdating = False
End Sub

【参考方案2】：

您当前的代码给了我有关范围对象的错误。我保持简单并将单元格值分配给单元格值。另外，我不确定您的意思是 0.01 还是 0.001。你可以摆弄那个。我看到的问题是，当你找到更多匹配项时，你希望 lastrow 上升，所以你写的是现在的最后一行，而不是以前的。您还粘贴了一些未使用的变量，所以我简化了。结果如下。

    Sub COPYCell()
Dim Last As Long
Dim i As Long

Last = 61
Dim lastrow As Long

lastrow = Sheets("Sheet1").Range("DA100").End(xlUp).Row + 1

For i = 5 To Last
    If (Cells(i, "J").Value <= 0.26) And (Cells(i, "J").Value >= 0.001) Then

           Cells(lastrow, "DA").Value = Cells(i, "J").Value
           Cells(lastrow, "DB").Value = Cells(i, "C").Value
           Cells(lastrow, "DC").Value = "July"
           lastrow = lastrow + 1
         End If
         Next i
End Sub

编辑在每条评论的 lastRow 上添加了 +1。我已经测试了我还没有的地方。

【讨论】：

感谢杰里米，感谢您的回答。这就是我所追求的，我是如此接近......但如此遥远

Jeremy，如果我运行相同的代码（针对不同的范围进行了调整），它会覆盖之前的粘贴单元格吗？我需要它粘贴到下一个空单元格中。

只需在“lastrow = Sheets("Sheet1").Range("DA100").End(xlUp).Row”末尾添加“+1”

我想这也取决于如何针对不同的范围进行调整。不同的行？列？无论如何，如果 @DisplayName 的修复还不够，请大喊大叫。

谢谢 DisplayName，谢谢 Jeremy Kahan

【参考方案3】：

您需要循环您的范围并在循环内检查您的单元格是否为空，复制单元格值，否则粘贴到下一个空单元格中。

示例代码：

Sub Func ()
Dim rng As Range, cell As Range
Set rng = Range("A1:A3")
For Each cell In rng
  If (IsEmpty(cell.value))
    Cell.paste()
  Else 
    cell.copy()
  End if
Next cell
End sub

代码没有经过测试，因为我是在手机上输入的。

【讨论】：

嗨 Abhishek，感谢您的评论，但我不知道如何解决我的问题。你能帮忙吗？