选择范围 .cells 的方法在第二次失败

Question

我已经在下面的代码上工作了一段时间，我几乎完成了。它从一张表中获取 3 个单元格的数据，将其复制到另一张表中，根据第一张表中的名称保存副本，然后循环直到完成所有填充的行。

我遇到的问题是，当第一个循环完成并且它需要选择保存数据的WB（该功能需要选择）时，由于@ 中的错误而无法选择它987654322@。当我调试时，切换到WB 并运行它确实可以工作的代码。 这可能是我想念的愚蠢的东西。感谢您的帮助！

Sub motivatieFormOpmaken()

        Dim wbMotivTemp As Workbook
        Dim wsMotiv As Worksheet
        Dim PathOnly, mot, FileOnly As String
        Dim StrPadSourcenaam As String
        Dim WsStam As Worksheet
        Dim WbStam As Workbook
        Dim LastRow As Long

    Set wbMotivTemp = ThisWorkbook
    Set wsMotiv = ActiveSheet

    StrHoofdDocument = ActiveWorkbook.Name
    StrPadHoofdDocument = ActiveWorkbook.Path
    StrPadSourcenaam = StrPadHoofdDocument & "\" & c_SourceDump

    If Not FileThere(StrPadSourcenaam) Then
       MsgBox "Document " & StrPadSourcenaam & " is niet gevonden."
    Exit Sub
    End If

    Application.ScreenUpdating = False

    Workbooks.Open FileName:=StrPadSourcenaam
    Set WbStam = ActiveWorkbook
    Set WsStam = WbStam.Worksheets("Stambestand")
    Application.Run "Stambestand.xlsm!unhiderowsandcolumns"
    Worksheets("stambestand").Activate

    iLaatsteKolom = Worksheets("stambestand").Cells.SpecialCells(xlLastCell).Column
    iLaatsteRij = Worksheets("stambestand").Cells.SpecialCells(xlLastCell).row

    VulKolomNr
    If KolomControle = False Then Exit Sub

    Cells(1, iKolomnrVerwijderen_uit_de_tellingen).AutoFilter Field:=iKolomnrVerwijderen_uit_de_tellingen, Criteria1:="0"
    LastRow = Cells(1, iKolomnrCorpID).End(xlDown).row

    Dim row As Long
    row = 2
    With WsStam
        Do Until row > iLaatsteRij
            If .Cells(row, iKolomnrCorpID).RowHeight > 0 Then
                WsStam.Cells(row, iKolomnrCorpID).EntireRow.Select 'It crashes at this line, after the first loop
                wsMotiv.Range("motiv_cid") = Cells(row, iKolomnrCorpID).Text
                wsMotiv.Range("motiv_naam") = Cells(row, iKolomnrNaam).Text
                wsMotiv.Range("motiv_ldg") = Cells(row, iKolomnrHuidigeLeidingGevende).Text
                n = naamOpmaken
                wbMotivTemp.Activate
                ActiveWorkbook.SaveAs FileName:=StrPadHoofdDocument & "\Docs\" & n & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
            End If
            row = row + 1
        Loop
    End With

End Sub

Function naamOpmaken() As String
    Dim rng As Range
    Dim row As Range
    Set rng = Selection.SpecialCells(xlCellTypeVisible)

    iRijnummer = rng.row
        If iRijnummer > 1 Then
            naam = Cells(iRijnummer, iKolomnrNaam).Text
            ldg = Cells(iRijnummer, iKolomnrHuidigeLeidingGevende).Text
            cid = Cells(iRijnummer, iKolomnrCorpID).Text

            Dim Position As Long, Length As Long
            Dim n As String
            Position = InStrRev(naam, " ")
            Length = Len(naam)
            n = Right(naam, Length - Position)
        End If
    naamOpmaken = n + "-" + ldg + "-" + cid
End Function

Answer 1

您必须在选择单元格之前激活工作表

因为你要在工作表之间跳跃，所以你必须添加

WsStam.Activate

就在之前

WsStam.Cells(row, iKolomnrCorpID).EntireRow.Select

顺便说一句，您似乎根本不需要该选择，因此您可能想尝试并评论该行！

Answer 2

希望您会发现这对未来有用。

我查看了您的代码并进行了一些更新，因此您不必选择任何工作表，并且该问题行已完全删除。我还在底部添加了一个新功能，它可以在您引用的任何工作表上找到最后一个单元格。

Option Explicit  'Very important at top of module.
                 'Ensures all variables are declared correctly.

Sub motivatieFormOpmaken()

    Dim wbMotivTemp As Workbook
    Dim wsMotiv As Worksheet
'    Dim PathOnly, mot, FileOnly As String

    '''''''''''''''''''
    'New code.
    Dim PathOnly As String, mot As String, FileOnly As String
    '''''''''''''''''''

    Dim StrPadSourcenaam As String

    '''''''''''''''''''
    'New code.
    Dim StrHoofdDocument As String
    Dim StrPadHoofdDocument As String
    Dim c_SourceDump As String
    c_SourceDump = "MyFileName.xlsx"
    Dim KolomControle As Boolean
    '''''''''''''''''''


    Dim WsStam As Worksheet
    Dim WbStam As Workbook
    Dim LastRow As Long

    Set wbMotivTemp = ThisWorkbook
    Set wsMotiv = ActiveSheet

    StrHoofdDocument = ActiveWorkbook.Name
    StrPadHoofdDocument = ActiveWorkbook.Path
    StrPadSourcenaam = StrPadHoofdDocument & "\" & c_SourceDump

    If Not FileThere(StrPadSourcenaam) Then
       MsgBox "Document " & StrPadSourcenaam & " is niet gevonden."
    Else
'    Exit Sub
'    End If

        Application.ScreenUpdating = False

'        Workbooks.Open Filename:=StrPadSourcenaam
'        Set WbStam = ActiveWorkbook

        '''''''''''''''''''
        'New code.
        Set WbStam = Workbooks.Open(Filename:=StrPadSourcenaam)
        '''''''''''''''''''

        Set WsStam = WbStam.Worksheets("Stambestand")
'        Application.Run "Stambestand.xlsm!unhiderowsandcolumns"

        '''''''''''''''''''
        'New code as possible replacement for "unhiderowsandcolumns"
        WsStam.Cells.EntireColumn.Hidden = False
        WsStam.Cells.EntireRow.Hidden = False
        '''''''''''''''''''

'        Worksheets("stambestand").Activate

'        iLaatsteKolom = Worksheets("stambestand").Cells.SpecialCells(xlLastCell).Column
'        iLaatsteRij = Worksheets("stambestand").Cells.SpecialCells(xlLastCell).row

        '''''''''''''''''''
        'New code.  You may want to check for filters before finding last row?
        iLaatsteKolom = LastCell(WsStam).Column
        iLaatsteRij = LastCell(WsStam).row
        '''''''''''''''''''

        VulKolomNr 'No idea - getting deja vu here.
'        If KolomControle = False Then Exit Sub

        '''''''''''''''''''
        'New code.
        If KolomControle Then
        '''''''''''''''''''

            WsStam.Cells(1, iKolomnrVerwijderen_uit_de_tellingen).AutoFilter Field:=iKolomnrVerwijderen_uit_de_tellingen, Criteria1:="0"
'            LastRow = Cells(1, iKolomnrCorpID).End(xlDown).row

            '''''''''''''''''''
            'New code.  The function will return the last filtered row.
            LastRow = LastCell(WsStam).row
            '''''''''''''''''''

            Dim row As Long
            row = 2
            With WsStam
                Do Until row > iLaatsteRij
                    If .Cells(row, iKolomnrCorpID).RowHeight > 0 Then
'''''''''''''''''''
'I don't think you even need this line.
'                        WsStam.Cells(row, iKolomnrCorpID).EntireRow.Select 'It crashes at this line, after the first loop
'                        wsMotiv.Range("motiv_cid") = Cells(row, iKolomnrCorpID).Text
'                        wsMotiv.Range("motiv_naam") = Cells(row, iKolomnrNaam).Text
'                        wsMotiv.Range("motiv_ldg") = Cells(row, iKolomnrHuidigeLeidingGevende).Text

                        '''''''''''''''''''
                        'New code.  Note the "." before "Cells" which tells it that cell is on "WsStam" (in the "With")
                        '           Also formatting the cell to text - will need to update as required.
                        wsMotiv.Range("motiv_cid") = Format(.Cells(row, iKolomnrCorpID), "0000")
                        wsMotiv.Range("motiv_naam") = Format(.Cells(row, iKolomnrNaam), "0000")
                        wsMotiv.Range("motiv_ldg") = Format(.Cells(row, iKolomnrHuidigeLeidingGevende), "0000")

'Do you mean this to save on each loop?
'                        n = naamOpmaken
'                        wbMotivTemp.Activate
'                        ActiveWorkbook.SaveAs Filename:=StrPadHoofdDocument & "\Docs\" & n & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

                        '''''''''''''''''''
                        'New code.  Combines the above three lines.
                        wbMotivTemp.SaveAs Filename:=StrPadHoofdDocument & "\Docs\" & naamOpmaken(WsStam) & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

                    End If
                    row = row + 1
                Loop
            End With

        '''''''''''''''''''
        'New code. End of "If KolomControle" block.
        End If
        '''''''''''''''''''

    ''''''''''''''''
    'New code - end of "If Not FileThere" block.
    'Give procedure a single exit point.
    End If

End Sub

'Added the worksheet as an argument to the procedure.
'This is then passed from the main procedure and you don't need to select the sheet first.
Function naamOpmaken(wrkSht As Worksheet) As String
    Dim rng As Range
    Dim row As Range
    Set rng = Selection.SpecialCells(xlCellTypeVisible)

    '''''''''''''''''''
    'New code
    Dim naam As String
    Dim ldg As String
    Dim cid As String
    '''''''''''''''''''

    iRijnummer = rng.row
        If iRijnummer > 1 Then

'            naam = Cells(iRijnummer, iKolomnrNaam).Text
'            ldg = Cells(iRijnummer, iKolomnrHuidigeLeidingGevende).Text
'            cid = Cells(iRijnummer, iKolomnrCorpID).Text

            '''''''''''''''''''
            'New code - not reference to the worksheet, and using default value of cell.
            '           may need to add "FORMAT" to get numericals in correct format.
            naam = wrkSht.Cells(iRijnummer, iKolomnrNaam)
            ldg = wrkSht.Cells(iRijnummer, iKolomnrHuidigeLeidingGevende)
            cid = wrkSht.Cells(iRijnummer, iKolomnrCorpID)
            '''''''''''''''''''

            Dim Position As Long, Length As Long
            Dim n As String
            Position = InStrRev(naam, " ")
            Length = Len(naam)
            n = Right(naam, Length - Position)
        End If

'If n and ldg are numbers this will add them rather than stick them together.
'    naamOpmaken = n + "-" + ldg + "-" + cid

    ''''''''''''''''
    'New code
    naamOpmaken = n & "-" & ldg & "-" & cid
    ''''''''''''''''

End Function

'New function to find last cell containing data on sheet.
Public Function LastCell(wrkSht As Worksheet) As Range

    Dim lLastCol As Long, lLastRow As Long

    On Error Resume Next

    With wrkSht
        lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
        lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).row

        If lLastCol = 0 Then lLastCol = 1
        If lLastRow = 0 Then lLastRow = 1

        Set LastCell = wrkSht.Cells(lLastRow, lLastCol)
    End With
    On Error GoTo 0

End Function