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

Question

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

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

一直到列表完成为止[复制数据]。 复制 新结果 之前的数据 预期 数据复制到其他列中

任何帮助，将不胜感激。

Answer 1

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

---

VBA代码：

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

结果：

---

编辑：复制到另一个工作表。

Sub copyNonBlankData()
Dim erow As Long, lastrow As Long, i As Long
Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("Sheet1") 'Sheet name
Dim ws2 As Worksheet
Set ws2 = ActiveWorkbook.Worksheets("Sheet2") 'Sheet name

lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
erow = ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

For i = 4 To lastrow
    If ws.Cells(i, 1) <> "" Then
        ws.Range(ws.Cells(i, 1), ws.Cells(i, 1)).Copy 'Copy Serial number
        ws2.Range(ws2.Cells(erow, 1), ws2.Cells(erow, 1)).PasteSpecial xlPasteAll 'Paste serial
        ws.Range(ws.Cells(i, 2), ws.Cells(i, 2)).Copy 'Copy date
        ws2.Range(ws2.Cells(erow, 3), ws2.Cells(erow, 3)).PasteSpecial xlPasteAll 'Paste serial
        ws.Range(ws.Cells(i, 3), ws.Cells(i, 4)).Copy 'Copy values
        ws2.Range(ws2.Cells(erow, 5), ws2.Cells(erow, 6)).PasteSpecial xlPasteAll 'Paste values
        ws2.Range(ws2.Cells(erow, 4), ws2.Cells(erow, 4)).Interior.Color = RGB(255, 242, 204) 'Fill Colour in 3rd column
        ws2.Range(ws2.Cells(erow, 2), ws2.Cells(erow, 2)).Borders(xlEdgeBottom).LineStyle = xlContinuous 'Add borders to 2nd column
        ws2.Range(ws2.Cells(erow, 4), ws2.Cells(erow, 4)).Borders(xlEdgeBottom).LineStyle = xlContinuous 'Add borders to 4th column
        erow = erow + 1
    End If
Next i
Application.CutCopyMode = False
End Sub

更有效的代码

Sub copyNonBlankData()
Dim erow As Long, lastrow As Long, i As Long
Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("Sheet1") 'Copy From - Sheet name
Dim ws2 As Worksheet
Set ws2 = ActiveWorkbook.Worksheets("Sheet2") 'Paste To - Sheet name

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False

lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
erow = ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

For i = 4 To lastrow
    If ws.Cells(i, 1) <> "" Then
        With ws.Range(ws.Cells(i, 1), ws.Cells(i, 1))
            ws2.Range(ws2.Cells(erow, 1), ws2.Cells(erow, 1)).Value = .Value
        End With
        With ws.Range(ws.Cells(i, 2), ws.Cells(i, 2))
            ws2.Range(ws2.Cells(erow, 3), ws2.Cells(erow, 3)).Value = .Value
        End With
        With ws.Range(ws.Cells(i, 3), ws.Cells(i, 4))
            ws2.Range(ws2.Cells(erow, 5), ws2.Cells(erow, 6)).Value = .Value
            ws2.Range(ws2.Cells(erow, 3), ws2.Cells(erow, 7)).Interior.Color = RGB(255, 242, 204) 'Fill Colour in 3rd column
            ws2.Range(ws2.Cells(erow, 1), ws2.Cells(erow, 7)).Borders.LineStyle = xlContinuous 'Add borders to 2nd column
        End With
        erow = erow + 1
    End If
Next i
Application.CutCopyMode = False

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True

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