Copy and paste rows from one to another worksheet VBA

Question

I know already a few people had that problem but their solutions did not help me. I am pretty new to VBA and I want to copy a row if the respective first cell is not empty to another file and iterate as long as the data is.

So far so good. My code runs the first time and actually works (for one line). But then the macro does not open the file again and spits out an error. If I want to manually open the target file it says: "Removed Feature: Data Validation from /xl/worksheets/sheet2.xml part" (and I think this is the reason why it does not iterate further). Do you have any idea what I can do?

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

Data Validation for the file is corrupt (dropdown lists) - either delete Data Validation, or fix it

Once the file is fixed, the code bellow will copy the data without opening the destination file multiple times. It AutoFilters current sheet for empty values in column BK (63) , and copies all visible rows, from columns BC to BK , to the end of the new file (starting at first unused cell in column 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