将行从一个行复制并粘贴到另一个工作表VBA

Question

我知道已经有几个人遇到了这个问题，但是他们的解决方案并没有帮助我。 我对VBA还是很陌生，如果相应的第一个单元格不为空，我想复制一行到另一个文件，并且只要数据就重复。

到现在为止还挺好。 我的代码是第一次运行，并且可以正常工作（一行）。 但是然后宏不会再次打开文件并吐出错误。 如果我想手动打开目标文件，它说：“已删除功能：来自/xl/worksheets/sheet2.xml的数据验证”（而且我认为这就是它不再进行迭代的原因）。 你知道我能做什么吗？

Sub transferData()

Dim LastRow As Long, i As Integer, erow As Long

LastRow = ActiveSheet.Range("BC" & Rows.Count).End(xlUp).Row

For i = 3 To LastRow

If IsEmpty(Cells(i, 63).Value) = False Then
Range(Cells(i, 55), Cells(i, 63)).Select
Selection.Copy

Workbooks.Open Filename:="PATH.xlsx"
Worksheets("NewProjects").Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row


ActiveSheet.Cells(erow, 1).Select
ActiveSheet.PasteSpecial
ActiveSheet.Sort.SortFields.Clear
ActiveWorkbook.Save
ActiveWorkbook.Close SaveChanges:=False
Application.CutCopyMode = False
End If

Next i
End Sub

Answer 1

文件的数据验证已损坏 （下拉列表）-删除或修复数据验证

修复文件后，下面的代码将复制数据，而无需多次打开目标文件。 它会自动AutoFilters当前工作表中BK (63)列BK (63)空值，并将所有可见行（从BC to BK列BC to BK列BK (63)复制到新文件的末尾（从A列中第一个未使用的单元格开始）

---

Option Explicit

Public Sub TransferData()
    Const OLD_COL1 = "BC"
    Const OLD_COL2 = "BK"
    Const NEW_COL1 = "A"
    Dim oldWb As Workbook, oldWs As Worksheet, oldLR As Long
    Dim newWb As Workbook, newWs As Worksheet, newLR As Long

    On Error Resume Next 'Expected errors: new file not found, new sheet name not found

    Set oldWb = ThisWorkbook
    Set oldWs = ActiveSheet     'Or: Set oldWs = oldWb.Worksheets("Sheet2")
    oldLR = oldWs.Cells(oldWs.Rows.Count, OLD_COL1).End(xlUp).Row
    Application.ScreenUpdating = False
    Set newWb = Workbooks.Open(Filename:="PATH.xlsx")
    Set newWs = newWb.Worksheets("NewProjects")
    If Not newWs Is Nothing Then
        newLR = newWs.Cells(oldWs.Rows.Count, NEW_COL1).End(xlUp).Row
        With oldWs.Range(oldWs.Cells(2, OLD_COL2), oldWs.Cells(oldLR, OLD_COL2))
            .AutoFilter Field:=1, Criteria1:="<>"
            If .SpecialCells(xlCellTypeVisible).Cells.Count > 2 Then
                oldWs.Range(oldWs.Cells(3, OLD_COL1), oldWs.Cells(oldLR, OLD_COL2)).Copy
                newWs.Cells(newLR + 1, NEW_COL1).PasteSpecial
                Application.CutCopyMode = False
                newWs.Sort.SortFields.Clear
                newWb.Close SaveChanges:=True
            Else
                newWb.Close SaveChanges:=False
            End If
            .AutoFilter
        End With
    End If
    Application.ScreenUpdating = True
End Sub