时间戳

首页 > 解决方案 > 如何复制和粘贴单元格，然后使用 excel VBA 以特定方式删除某些行？

excel - 如何复制和粘贴单元格，然后使用 excel VBA 以特定方式删除某些行？

问题描述

我必须先说我在 VBA 方面低于最低水平的新手。我目前在 excel 中有一列数据，当您从该列向下移动时，有关公司的信息以三行一组的形式存储。数据分组如下（数据之间没有空行）：

A公司

www.CompanyA.com

公司位置

B公司

www.CompanyB.com

公司B位置...等。

我需要创建一个代码来复制下面的单元格，将其粘贴到右侧的单元格中，然后删除下面的行。然后复制现在下面的单元格，并将其粘贴到右侧两个，然后选择下一个单元格并重复下一个三行数据集。如果这有助于解释我的想法，我在下面包含了我糟糕的初稿。任何帮助将不胜感激。谢谢！

Sub Clean()

Do Until IsEmpty(ActiveCell.Value)

Range("A1").Activate

Selection.Offset(1, 0).Copy

Selection.Offset(0, 1).Paste

ActiveCell.Offset(1, 0).EntireRow.Delete xlShiftUp

Selection.Offset(1, 0).Copy

Selection.Offset(0, 2).Paste

ActiveCell.Offset(1, 0).EntireRow.Delete xlShiftUp

ActiveCell.Offset(1, 0).Select

Loop

End Sub

标签： excelvbamacos

解决方案

这可以帮助你做你想做的事。不是最好的解决方案，但这将比你所做的更快地循环所有单元格。

Sub test()
    Dim lRow As Long, i As Long
    Dim ws As Worksheet
    Dim RowsToDelete As Range

    Set ws = ActiveSheet
    With ws
        lRow = .Cells(.Rows.Count, 1).End(xlUp).Row ' Get the last row
        For i = lRow To 1 Step -3 
            .Cells(i - 2, 3) = .Cells(i, 1)
            .Cells(i - 2, 2) = .Cells(i - 1, 1)

            If RowsToDelete Is Nothing Then 'first 2 rows to be deleted
                Set RowsToDelete = Range(.Rows(i).EntireRow, .Rows(i - 1).EntireRow)
            Else 'append more rows with union
                Set RowsToDelete = Application.Union(RowsToDelete, .Rows(i).EntireRow, .Rows(i - 1).EntireRow)
            End If

        Next i

        If Not RowsToDelete Is Nothing Then 'if there is something to be deleted
            RowsToDelete.Delete
        End If
    End With
End Sub

推荐阅读