如何创建动态范围和改进 vba 代码

如何解决如何创建动态范围和改进 vba 代码

我有一些代码（如下）我想改进，因为我发现它在每天变化的范围方面有点笨拙，理想情况下我想使用最后一行而不是使用大量范围但是，遗憾的是我没有那么聪明:(

这是代码，如果有人想改进我将不胜感激，我认为这个过程是不言自明的（即自动过滤并从一张纸复制到另一张纸）

Sub Refresh_click()
Set DbExtract = ThisWorkbook.Sheets("Sheet1")
Set DuplicateRecords = ThisWorkbook.Sheets("Sheet2")
Sheets("Sheet2").Unprotect
Range("A4:A50").Select
Application.CutCopyMode = False
    Selection.ClearContents
Sheets("Sheet1").Select
ActiveSheet.ListObjects("Table22").Range.AutoFilter Field:=23,Criteria1:= _
    "="
DbExtract.Range("F2:F99999").SpecialCells(xlCellTypeVisible).Copy
DuplicateRecords.Range("A4:A50").PasteSpecial Paste:=xlPasteValues,Operation:=xlNone,SkipBlanks _
    :=False,Transpose:=False
Sheets("Sheet2").Protect
Sheets("Sheet1").Select
ActiveSheet.ListObjects("Table22").Range.AutoFilter Field:=23
MsgBox "Log - Updated"
End Sub

解决方法

请以这种方式尝试：

Sub Refresh_click()
 Dim DbExtract As Worksheet,DuplicateRecords As Worksheet,lastFRow As Long

 Set DbExtract = ThisWorkbook.Sheets("Sheet1")
 Set DuplicateRecords = ThisWorkbook.Sheets("Sheet2")

 With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
    .CutCopyMode = False
 End With
 With DuplicateRecords
    .Unprotect
    .Range("A4:A50").ClearContents
 End With

 DbExtract.ListObjects("Table22").Range.AutoFilter field:=23,Criteria1:="="
 
 lastFRow = DbExtract.Range("F" & rows.count).End(xlUp).row 'last row of F:F col
 DbExtract.Range("F2:F" & lastFRow).SpecialCells(xlCellTypeVisible).Copy
 DuplicateRecords.Range("A4").PasteSpecial Paste:=xlPasteValues,Operation:=xlNone,SkipBlanks _
                                                                        :=False,Transpose:=False
 DuplicateRecords.Protect

 DbExtract.ListObjects("Table22").Range.AutoFilter field:=23
 
 With Application
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
    .ScreenUpdating = True
 End With
 
 MsgBox "Log - Updated"
End Sub

请进行测试并发送一些反馈。我无法测试它...

,

使用自动过滤器复制

• 调整常量部分中的值。

代码

Option Explicit

Sub Refresh_click()
    
    Const srcName As String = "Sheet1"
    Const srcTblName As String = "Table22"
    Const srcCol As Long = 6
    Const srcField As Long = 23
    Const srcCrit As String = "="
    Const dstName As String = "Sheet2"
    Const dstFirst As String = "A4"
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim cel As Range
    Dim rng As Range
    Dim Updated As Boolean
    
    With wb.Worksheets(dstName)
        .Unprotect
        Set cel = .Range(dstFirst)
        cel.Resize(cel.Worksheet.Rows.Count - cel.Row + 1).ClearContents
        With wb.Worksheets(srcName).ListObjects(srcTblName)
            .Range.AutoFilter
            Set rng = .ListColumns(srcCol).Range _
                .Resize(.ListRows.Count).Offset(1)
            'Debug.Print rng.Address
            .Range.AutoFilter Field:=srcField,Criteria1:=srcCrit
            On Error Resume Next
            rng.SpecialCells(xlCellTypeVisible).Copy
            On Error GoTo 0
            If Application.CutCopyMode = xlCopy Then
                cel.PasteSpecial xlPasteValues
                Updated = True
            End If
            .Range.AutoFilter
        End With
        .Protect
    End With
    
    If Updated Then
        MsgBox "Log updated.",vbInformation,"Success"
    Else
        MsgBox "Log not updated.",vbCritical,"Fail"
    End If
    
End Sub