移动工作表许多部分的宏出现语法错误，我哪里出错了？

问题描述 投票：0回答：1

我不知何故破坏了几个月前VBasic2008给我的这个超级棒的代码。工作簿变得非常慢，可能是因为我没有正确使用它，而我只是不断地将东西固定在上面。因此，我刚刚重新创建了它，看看是否可以简化一些添加内容以及是否可以删除任何步骤。 我有一个宏可以运行大多数其他宏，但是当它运行并移动到移动许多不同类型的行的进程的大部分部分时，我收到了以前没有的语法错误。它在第一部分（NoAddress）给了我错误，所以我希望它在以下每个部分上执行相同的操作。


Sub MoveMatchingRows( _
        ByVal SourceWorksheet As Worksheet, _
        ByVal SourceColumn As Long, _
        ByVal SourceCriteria As Variant, _
        ByVal DestinationWorksheet As Worksheet, _
        Optional ByVal DestinationColumn As Long = 1, _
        Optional ByVal DoClearPreviousDestinationData As Boolean = False)
    
    Const ProcTitle As String = "Move Matching Rows"
    
    ' Remove any previous filters.
    If SourceWorksheet.AutoFilterMode Then
        SourceWorksheet.AutoFilterMode = False
    End If
    
    ' Filter.
    Dim srg As Range ' Source Range (Headers and Data)
    Set srg = SourceWorksheet.Range("A1").CurrentRegion
    srg.AutoFilter SourceColumn, SourceCriteria, xlFilterValues
    
    ' Create a reference to the Source Data Range (no headers).
    Dim sdrg As Range
    Set sdrg = srg.Resize(srg.Rows.Count - 1).Offset(1)
    
    ' Clear Destination worksheet.
    If DoClearPreviousDestinationData Then ' new data, copies headers
        DestinationWorksheet.Cells.Clear
    End If
    
    ' Attempt to create a reference to the Source Data Filtered Rows Range.
    Dim sdfrrg As Range
    On Error Resume Next
        Set sdfrrg = sdrg.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    If Not sdfrrg Is Nothing Then
        
        ' Create a reference to the Destination Cell (also, add headers).
        Dim dCell As Range ' Destination Cell
        Set dCell = DestinationWorksheet.Cells(1, DestinationColumn)
        If IsEmpty(dCell) Then
            srg.Rows(1).Copy dCell
            Set dCell = dCell.Offset(1)
        Else
            Set dCell = DestinationWorksheet.Cells( _
                DestinationWorksheet.Rows.Count, DestinationColumn) _
                .End(xlUp).Offset(1, 0)
        End If
        
        With sdfrrg
            .Copy dCell
            
            ' Either delete the entire worksheet rows...
            '.EntireColumn.Delete
            
            ' ... or remove filter to prevent...
            SourceWorksheet.AutoFilterMode = False
            ' ... deleting the entire worksheet rows leaving possible data
            ' to the right (after the empty column) intact.
            .Delete xlShiftUp
        
        End With
    
    Else ' no matches
        
        SourceWorksheet.AutoFilterMode = False
   
    End If
        
End Sub
_____________________________________________________________________

Sub NoAddress()
    MoveMatchingRows Sheet1, 6, "=", Sheet12, 1, False
End Sub
________________________________________________

Sub Zoos()
    MoveMatchingRows Sheet1, 4, "*Zoos*", Sheet11, 1, False
End Sub
______________________________________

Sub MoveMemorial()
    MoveMatchingRows Sheet1, 18, "Memorial", Sheet6, 1, False
End Sub
_______________________________________

Sub MoveHonor()
    MoveMatchingRows Sheet1, 18, "Honor", Sheet6, 1, False
End Sub
_______________________

Sub MoveMatchingGift()
    MoveMatchingRows Sheet1, 4, "*Matching Gift*", Sheet9, 1, False
End Sub
______________________

Sub MovePayroll()
    MoveMatchingRows Sheet1, 4, "*Payroll*", Sheet9, 1, False
End Sub
________________________________

Sub NotGenOpFund()
    MoveMatchingRows Sheet1, 23, "<>*FD.IND.GenOp*", Sheet12, 1, False
End Sub
_____________________________________________________________________

Sub GiftMemberships()
    MoveMatchingRows Sheet1, 15, "<>", Sheet10, 1, False
End Sub
_____________________________________________________________________

Sub More_Gift_Mems()
    MoveMatchingRows Sheet1, 25, "*gift for*", Sheet10, 1, False
End Sub
____________________________________________________________________

Sub Gift_Mem_Recipient()
    MoveMatchingRows Sheet1, 31, "<>", Sheet10, 1, False
End Sub
__________________________________

Sub Move_Managed()
    MoveMatchingRows Sheet1, 19, "<>", Sheet5, 1, False
End Sub
___________________________

Sub Stock_InKind_IRA()
    MoveMatchingRows Sheet1, 34, "<>", Sheet7, 1, False
End Sub
_____________________________________________________________________

Sub Move_DAF()
    MoveMatchingRows Sheet1, 42, "<>*/*", Sheet8, 1, False
End Sub
______________________

Sub Oddballs()
    MoveMatchingRows Sheet1, 3, "<> *AF.IND*", Sheet12, 1, False
End Sub
_____________________________


Sub Over_500_Unmanaged()
    MoveMatchingRows Sheet1, 15, ">=500", Sheet4, 1, False
End Sub
_____________________________

Sub Over_250_Unmanaged()
    MoveMatchingRows Sheet1, 15, ">=250", Sheet3, False
End Sub

我在这里做错了什么？

更新（4.8.22） 我从所有内容中删除了“...1，FALSE”，但我仍然收到一条错误，指出子例程可能不可用或所有宏可能被禁用。当您说要在我的所有数字周围加上引号时，您并不是在谈论引用数据列的数字，对吗？我不认为你是，但我还是尝试了，但没有帮助。您对我下一步可以尝试什么有什么建议吗？

arrays excel vba syntax-error
1个回答
1
投票

将筛选的行移动到另一个工作表

  • 这是另一个改进。希望它会比第一个持续更长时间。
  • 使用数字时会失败，因此请将它们放在引号中，例如
    "7"
    。
  • xlFilterValues
    用于允许多个条件，例如
    Array("4", "7")
    或 
    Array("Yes", "Maybe")
    。
  • 您的所有示例都使用参数 
    1
    和 
    False
    作为最后两个参数。您可以安全地忽略它们，因为它们是默认值，即 
    MoveMatchingRows Sheet1, 6, "=", Sheet12
    （
    Optional... = 1
    和 
    Optional... = False
    的含义）。
  • 在上一个示例中，您使用 
    False
    作为第五个参数，而不是合理的正整数，因此它会失败，即使用这个新代码，它几乎什么也不做。
Option Explicit

Sub MoveFilteredRows( _
        ByVal SourceWorksheet As Worksheet, _
        ByVal SourceColumn As Long, _
        ByVal SourceCriteria As Variant, _
        ByVal DestinationWorksheet As Worksheet, _
        Optional ByVal DestinationColumn As Long = 1, _
        Optional ByVal DoClearPreviousDestinationData As Boolean = False)
    Const ProcName As String = "MoveFilteredRows"
    On Error GoTo ClearError
    
    ' Show all rows if the source worksheet is filtered.
    If SourceWorksheet.FilterMode Then SourceWorksheet.ShowAllData
    
    ' Reference the source range (has headers).
    Dim srg As Range ' Source Range (one row of headers and data)
    Set srg = SourceWorksheet.Range("A1").CurrentRegion
    
    ' Show all rows if the destination worksheet is filtered.
    If DestinationWorksheet.FilterMode Then DestinationWorksheet.ShowAllData
    
    ' Reference the destination first cell and take care of the headers.
    Dim dfCell As Range
    If DoClearPreviousDestinationData Then
        DestinationWorksheet.UsedRange.Clear
        Set dfCell = DestinationWorksheet.Cells(1, DestinationColumn)
        srg.Rows(1).Copy dfCell ' copy headers
        If srg.Rows.Count = 1 Then Exit Sub
        Set dfCell = dfCell.Offset(1)
    Else
        If srg.Rows.Count = 1 Then Exit Sub ' don't want to copy headers
        With DestinationWorksheet.Columns(DestinationColumn) _
                .Resize(, srg.Columns.Count)
            Set dfCell = .Find("*", , xlFormulas, , xlByRows, xlPrevious)
            If dfCell Is Nothing Then
                Set dfCell = .Cells(1)
                srg.Rows(1).Copy dfCell ' copy headers anyway
                Set dfCell = dfCell.Offset(1)
            Else
                Set dfCell = .Cells(dfCell.Row + 1, 1)
            End If
        End With
    End If
    
    ' Filter.
    srg.AutoFilter SourceColumn, SourceCriteria, xlFilterValues
    
    ' (Attempt to) reference the source data filtered range.
    Dim sdfrg As Range
    On Error Resume Next
        Set sdfrg = srg.Resize(srg.Rows.Count - 1).Offset(1) _
            .SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    SourceWorksheet.AutoFilterMode = False
    
    ' Move i.e. copy and delete
    If sdfrg Is Nothing Then Exit Sub
    sdfrg.Copy dfCell
    sdfrg.Delete xlShiftUp
    
ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Sub
最新问题
© www.soinside.com 2019 - 2024. All rights reserved.