Question

我有完美的代码运行循环遍历多个执行工作簿，以复制并粘贴到此主工作簿。它将查看相应执行工作簿的最后一行

readLastCellNameSheet = ExecutiveWorkBook.Sheets("Summary").Cells(Rows.Count, 1).End(xlUp).Row

然后粘贴到Masterworkbook。但是，当我插入4000行数据时，只有3000行插入到此主工作簿中。以下是完整的参考代码。我有多个具有不同行的执行工作簿需要复制到主工作簿中。一切正常，直到第3000行停止。有什么建议吗？

Sub UpdateDate_Click()

Dim readLastCell As Long
Dim readLastCellNameSheet As Long
Dim billNumber
Dim SheetName As String
Dim billNumberNamesheet As Long
Dim ExecutiveWorkBookPath As String
Dim excelFilePath
Dim ExecutiveWorkBook As Workbook
Dim MainTemplate As String

MainTemplate = ThisWorkbook.Name

ThisWorkbook.Sheets("Master").Unprotect "12345+"
ThisWorkbook.Worksheets("Master").Range("R1:AV20000").Locked = False
ThisWorkbook.Worksheets("Master").Range("R4:AV20000").Value = ""


'ChDir Defaulth path
excelFilePath = Application.ActiveWorkbook.Path + "\"
Application.EnableEvents = False
strFilename = Dir(excelFilePath & "\*xlsm")


Do While strFilename <> ""
    'Set variable equal to opened workbook
        If InStr(strFilename, "Executive") > 0 Then
            Set ExecutiveWorkBook = Workbooks.Open(excelFilePath & strFilename, ReadOnly:=True)
            ExecutiveWorkBook.Worksheets("Summary").Unprotect "12345+"
            ExecutiveWorkBook.Worksheets("Summary").Range("A1:Q22000").Locked = False

            readLastCell = ThisWorkbook.Sheets("Master").Cells(Rows.Count, 1).End(xlUp).Row
            readLastCellNameSheet = ExecutiveWorkBook.Sheets("Summary").Cells(Rows.Count, 1).End(xlUp).Row

                For x = 4 To readLastCellNameSheet
                cell = "A" & x
                billNumber = ThisWorkbook.Worksheets("Master").Range(cell).Value

                       If Len(billNumber) = 0 Then Exit For

                             For N = 4 To readLastCellNameSheet
                            cell = "A" & N
                            billNumberNamesheet = ExecutiveWorkBook.Worksheets("Summary").Range(cell).Value
                            If Len(billNumberNamesheet) = 0 Then Exit For

                            If billNumberNamesheet = billNumber Then
                                cell = "R" & N & ":" & "AV" & N
                                copycell = "R" & x & ":" & "AV" & x
                                ExecutiveWorkBook.Worksheets("Summary").Range(cell).Copy
                                ThisWorkbook.Worksheets("Master").Range(copycell).PasteSpecial Paste:=xlPasteAll

                            End If

                             Next N

                Next x
                        ExecutiveWorkBook.Worksheets("Summary").Range("A1:Q22000").Locked = True
                        ExecutiveWorkBook.Sheets("Summary").Protect "12345+", True, True
                        'ThisWorkbook.Worksheets("Master").Range("R1:AV20000").Locked = True
                        'ThisWorkbook.Sheets("Master").Protect "12345+", True, True
                        ' CLOSE THE SOURCE FILE.
                        ExecutiveWorkBook.Close savechanges:=False   ' FALSE - DON'T SAVE THE SOURCE FILE.
        Else

        End If



'to get next file name
strFilename = Dir
Loop
Application.EnableEvents = True
MsgBox "Updated Succesully"
End Sub

宏停止x行后的工作

0 个答案: