將行從一個行復制並粘貼到另一個工作表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