我想在工作代码上应用循环，以便单击即可工作 [英] I want to apply a loop on working code so it will able to work on single click

问题描述

我有用于将某些数据行从一个工作表复制到另一个工作表的代码.要复制，我不得不反复单击.一次单击仅运行一次代码.因此我尝试了 Do While ，但是在调试rng的过程中抛出了自动化错误.整个代码工作正常...只是想添加一个运行相同的代码不做IsEmpty(Range("A2"))).

I have code for copying some data rows from one worksheet to another. To copy I have repeatedly to click. A single click runs the code only once. So I tried Do While but that throws an Automation error during debugging on setting the rng. whole code is working fine....just want to add a run the same upto Do While Not IsEmpty(Range("A2")).

代码:

Do While Not IsEmpty(Range("A2"))

Application.ScreenUpdating = False

    Set WSheet = ThisWorkbook.Worksheets("InputWbLocation")
    Set wbLocationPath = WSheet.Range("A2")
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    While wbLocationPath.Value <> ""
        If IsWorkBookOpen(wbLocationPath.Value) Then
            For Each wks In Workbooks
                If (wks.Path & "\" & wks.Name) = wbLocationPath Then
                    Set wb = wks
                    Exit For
                End If
            Next wks

        Else
            Set wb = Application.Workbooks.Open(wbLocationPath.Value, ReadOnly:=False, UpdateLinks:=0)
        End If

        For Each tmpSheet In wb.Worksheets

        If tmpSheet.Visible = xlSheetVisible Then
        If tmpSheet.Name <> "Supplier Instructions" Then

            lastrow = tmpSheet.Cells(tmpSheet.Rows.Count, "A").End(xlUp).Row
            If lastrow <> 1 And lastrow <> tmpSheet.Rows.Count Then

            Set Foundcell = tmpSheet.Range("A2:A" & lastrow).Find(What:="To be Uploaded")

            If Foundcell Is Nothing Then
            Set Foundcell = tmpSheet.Range("A2:A" & lastrow).Find(What:="To be loaded")
            Set Foundcell = tmpSheet.Range("A2:A" & lastrow).Find(What:="To  be Uploaded")
            End If
            Set Foundcell2 = tmpSheet.Range("A2:A" & lastrow).Find(What:="Completed")



            Do Until Foundcell Is Nothing
                'copy paste entire row on Autoload sheet
                Set rng = Range(tmpSheet.Cells(1, 1), tmpSheet.Cells(lastrow, 1))
                Foundcell.EntireRow.Copy
                If (Foundcell.Offset(0, 2).Value = "" Or Foundcell.Offset(0, 6).Value = "" Or Foundcell.Offset(0, 15).Value = "") Then
                    Set pasteSheet = Sheet6
                    resultMessage = "Error"
                Else
                    If InStr(wb.Name, "xlsx") <> 0 Or InStr(wb.Name, "xlsm") <> 0 Then
                        Set pasteSheet = Sheet5
                        resultMessage = "Completed"
                    Else
                        If InStr(tmpSheet.Name, "Ana") <> 0 Then
                            Set pasteSheet = Sheet3
                            resultMessage = "Completed"
                        Else
                            Set pasteSheet = Sheet1
                            resultMessage = "Completed"
                        End If
                    End If
                End If
                RowCount = WorksheetFunction.CountA(pasteSheet.Range("A:A")) + 1

                For Each c In rng.Cells
                If LCase(Trim(c)) = "to be uploaded" Or LCase(Trim(c)) = "to be loaded" Or LCase(Trim(c)) = "to  be uploaded" Then
                c.EntireRow.Copy
                pasteSheet.Cells(pasteSheet.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues
                ActiveWorkbook.Saved = True
                Application.DisplayAlerts = False
                Application.EnableEvents = False

                End If
                Next c
               ActiveWorkbook.Close
               WSheet.Rows(2).Delete

            Loop



            Do Until Foundcell2 Is Nothing
            Set rng = Range(tmpSheet.Cells(1, 1), tmpSheet.Cells(lastrow, 1))
                'copy paste entire row on Autoload sheet
                Foundcell2.EntireRow.Copy
                If (Foundcell2.Offset(0, 2).Value = "" Or Foundcell2.Offset(0, 6).Value = "" Or Foundcell2.Offset(0, 15).Value = "") Then
                    Set pasteSheet = Sheet6
                    resultMessage = "Error"
                Else
                    If InStr(wb.Name, "xlsx") <> 0 Or InStr(wb.Name, "xlsm") <> 0 Then
                        Set pasteSheet = Sheet5
                        resultMessage = "Completed"
                    Else
                        If InStr(tmpSheet.Name, "Ana") <> 0 Then
                            Set pasteSheet = Sheet3
                            resultMessage = "Completed"
                        Else
                            Set pasteSheet = Sheet1
                            resultMessage = "Completed"
                        End If
                    End If
                End If
                RowCount = WorksheetFunction.CountA(pasteSheet.Range("A:A")) + 1

                For Each c In rng.Cells
                If LCase(Trim(c)) = "completed" Then
                c.EntireRow.Copy
                pasteSheet.Cells(pasteSheet.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues
                ActiveWorkbook.Saved = True
                Application.DisplayAlerts = False
                Application.EnableEvents = False

                End If
                Next c
                ActiveWorkbook.Close
                WSheet.Rows(2).Delete
         Loop

            End If
            End If
            End If

            Next tmpSheet

        wb.Close SaveChanges:=True
        Set wbLocationPath = wbLocationPath.Offset(1, 0)
    Wend


errHandler:
'Resume

Loop
End Sub

之后

Set `rng=...` 

抛出错误-自动化错误

推荐答案

问题是我在关闭循环内的wb之后试图设置rng.因此，它引发了错误，因为当控件尝试设置rng时，它没有得到tmpSheet，而是引发了它.因此，关闭工作表的代码应该不在循环中.

Problem was that I was trying to set rng after closing the wb inside the loop. So it's throwing the error because when the control was trying to set rng it was not getting the tmpSheet then it throw . So the code of Closing the sheet should be out of the loop.

这篇关于我想在工作代码上应用循环，以便单击即可工作的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！