VBA复制特定的单元格并粘贴到相邻列中

Question

我正在尝试创建VBA代码，该代码将特定单元格中的数据复制并粘贴到一系列单元格中，直到其为空。我在VBA方面没有丰富的经验，因此我正在努力创建这样的代码。

我想创建一个针对整个数据集循环的代码，因此例如B2单元将需要从A5复制到A9的单元中。然后，将B12从A15复制到A19。

然后一直到列表完成为止[复制数据]。Data Before Copying New Result Expected Data copy into different column

任何帮助将不胜感激。

Answer 1

一种略有不同的方法。动态的，您可以增加或减小Columna A（黄色部分）中的范围

---

VBA代码：

OnBeginAdd

结果：

---

编辑： 复制到另一张纸上。

OnEndAdd

更高效的代码

Sub CopyPaste()

Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("Sheet1")     'Sheet name
Dim lrow As Long
Dim cl As Variant
Dim myRange As Range
Dim currentRow As Long
Dim currentRowValue As String
Dim currRow As Long

lrow = ws.Cells(Rows.Count, 2).End(xlUp).Row     'Find last row in Sheet1
Set myRange = ws.Range(ws.Cells(1, 2), ws.Cells(lrow, 2)) 'Range you want to loop through in Column B, from row 1 to last row

For Each cl In myRange
    Debug.Print cl
    If cl.Value <> "" And cl.Value <> "Day Date" And Not IsDate(cl.Value) Then 'Ignore empty cells, Cells with the word "Day Date" or if the cells contain a date
        For currentRow = cl.Row + 2 To cl.Row + 10
            currentRowValue = Cells(currentRow, 2).Value
            If IsEmpty(currentRowValue) Or currentRowValue = "" Then 'Checks for empty rows in the area below
                currRow = Cells(currentRow, 2).Row
                Exit For
            End If
        Next
        Range(Cells(cl.Row, 1).Offset(3, 0), Cells(currRow - 1, 1)) = Cells(cl.Row, 2) 'Set current value in Column B to the adjacent range (Column A). Offset(3, 0) - this part sets the first cell in the range. Increase "+7" to make range larger
    End If
Next cl                                          'Next value to loop

End Sub

Answer 2

我的代码很糟糕，可能有点慢。我还没有测试。

写在移动设备上，对不起，格式化不正确。

Option Explicit

Sub FillDown()

' I assume Sheet1, change it to whatever your sheet's name is
With Thisworkbook.worksheets("Sheet1")

application.screenupdating = false
application.calculation = xlcalculationmanual

Dim lastRow as long
lastRow = .cells(.rows.count, "B").end(xlup).row

Dim rowIndex as long

For rowIndex = 1 to lastRow

If .cells(rowIndex, "B").value2 = "Day Date" then

.cells(rowIndex, "B").offset(3, -1).resize(5,1).value2 = .cells(rowIndex-2, "B").value2

rowIndex = rowIndex + 5
End if

Next rowIndex

End with

application.screenupdating = true
application.calculation = xlcalculationautomatic

End sub