Question

在将一组新数据复制到一组列之前，我想删除除标题以外的所有内容，我使用以下代码进行此操作：
wsS.Rows（“ 4：1048560”）。EntireRow.Delete

之所以这样，是因为数据分布在A列到AZ上，并且行长不同。

但是以某种方式，命令将保留先前包含数据的单元格，现在选择为空，但仅适用于A到F列（我复制了9个数据块，而对于每个块，我使用了不同的sub（）稍后在按钮内调用）。我还先在要复制数据的工作表上应用了过滤器。

我的问题是新副本以某种方式在其他数据应已结束的地方开始。我运行代码的次数越多，复制开始的行越多。复制代码是由某人在这里提出的，我只是对其稍作调整即可。

奇怪的是，如果我在立即窗口中运行上面的delete命令（或执行手动删除），然后再次运行完整代码，则复制的数据将按原样在A4单元格中启动。

在删除然后复制新数据之后，我还尝试对单元格A4进行选择。仍然没有成功。而且这仅发生在我复制的第一组数据（列A到F）中->我使用相同的代码复制了更多范围（A到F，H到M，O到T等）

这是一个代码块的代码，即从A到F：

Private Sub CopyDataAtoF()
Dim wsR As Worksheet:       Set wsR = ThisWorkbook.Worksheets("Data Raw")
Dim wsS As Worksheet:       Set wsS = ThisWorkbook.Worksheets("Scatter Raw")
Dim lrR As Long:            lrR = wsR.Cells(wsR.Rows.count, "A").End(xlUp).Row
Dim lrS1 As Long:           lrS1 = wsS.Cells(wsS.Rows.count, "A").End(xlUp).Row + 1
Dim lrS2 As Long:           lrS2 = wsS.Cells(wsS.Rows.count, "C").End(xlUp).Row + 1
Dim lrS3 As Long:           lrS3 = wsS.Cells(wsS.Rows.count, "E").End(xlUp).Row + 1

With wsR
    Dim fRng As Range:      Set fRng = .Range(.Cells(1, "A"), .Cells(lrR, "AN"))
    Dim rngN As Range:      Set rngN = .Range(.Cells(2, "N"), .Cells(lrR, "N"))
    Dim rngY As Range:      Set rngY = .Range(.Cells(2, "Y"), .Cells(lrR, "Y"))
    Dim cRng As Range:      Set cRng = Union(rngN, rngY)
End With

Application.ScreenUpdating = False
wsS.Rows("4:1048560").EntireRow.Delete Shift:=xlUp

fRng.AutoFilter field:=25, Criteria1:="<>", Operator:=xlFilterValues
fRng.AutoFilter field:=1, Criteria1:="criteria1", Operator:=xlFilterValues
If fRng.SpecialCells(xlCellTypeVisible).CountLarge > 2 Then
    cRng.Copy
    wsS.Cells(lrS1, "A").PasteSpecial xlPasteValues
    With wsS
        Dim vis1 As Long:    vis1 = .Cells(.Rows.count, "A").End(xlUp).Row
        Dim lcS1 As Long:    lcS1 = .Cells(lrS1, "A").End(xlToRight).Column + 1
        Dim divA As Range:   Set divA = .Range(.Cells(lrS1, "A"), .Cells(vis1, "A"))
        Dim divY1 As Range:  Set divY1 = .Range(.Cells(lrS1, lcS1), .Cells(vis1, lcS1))

        divY1.Formula = "=" & .Cells(lrS1, 1).Address(RowAbsolute:=False) & " / 1000"
        divA.Value2 = divY1.Value2
        divY1.ClearContents
    End With
End If

fRng.AutoFilter field:=1, Criteria1:="criteria2", Operator:=xlFilterValues
If fRng.SpecialCells(xlCellTypeVisible).CountLarge > 2 Then
    cRng.Copy
    wsS.Cells(lrS2, "C").PasteSpecial xlPasteValues
    With wsS
        Dim vis2 As Long:    vis2 = .Cells(.Rows.count, "C").End(xlUp).Row
        Dim lcS2 As Long:    lcS2 = .Cells(lrS2, "C").End(xlToRight).Column + 1
        Dim divC As Range:   Set divC = .Range(.Cells(lrS2, "C"), .Cells(vis2, "C"))
        Dim divY2 As Range:  Set divY2 = .Range(.Cells(lrS2, lcS2), .Cells(vis2, lcS2))

        divY2.Formula = "=" & .Cells(lrS2, 3).Address(RowAbsolute:=False) & " / 1000"
        divC.Value2 = divY2.Value2
        divY2.ClearContents
    End With
End If

fRng.AutoFilter field:=1, Criteria1:="criteria3", Operator:=xlFilterValues
If fRng.SpecialCells(xlCellTypeVisible).CountLarge > 2 Then
    cRng.Copy
    wsS.Cells(lrS3, "E").PasteSpecial xlPasteValues
    With wsS
        Dim vis3 As Long:    vis3 = .Cells(.Rows.count, "E").End(xlUp).Row
        Dim lcS3 As Long:    lcS3 = .Cells(lrS3, "E").End(xlToRight).Column + 1
        Dim divE As Range:  Set divE = .Range(.Cells(lrS3, "E"), .Cells(vis3, "E"))
        Dim divY3 As Range:  Set divY3 = .Range(.Cells(lrS3, lcS3), .Cells(vis3, lcS3))

        divY3.Formula = "=" & .Cells(lrS3, 5).Address(RowAbsolute:=False) & " / 1000"
        divE.Value2 = divY3.Value2
        divY3.ClearContents
    End With
End If

wsS.Range("A1").Select
wsR.AutoFilter.ShowAllData
Application.ScreenUpdating = True
End Sub

Answer 1

您遇到的问题是由于所有以lr为前缀的变量都存储了索引号 （总是）<删除所有包含数据的最后一行中的/ em>。

根据代码的编写方式，粘贴新数据时，它将从存储在lr-s中的索引号开始。

解决方案是在删除数据后重新计算lr-s的值。

将代码顶部替换为下面的修改后的代码，这些代码应能按您期望的方式工作。

Private Sub CopyDataAtoF() Dim wsR As Worksheet: Set wsR = ThisWorkbook.Worksheets("Data Raw") Dim wsS As Worksheet: Set wsS = ThisWorkbook.Worksheets("Scatter Raw") Application.ScreenUpdating = False wsS.Rows("4:1048560").EntireRow.Delete Shift:=xlUp Dim lrR As Long: lrR = wsR.Cells(wsR.Rows.count, "A").End(xlUp).Row Dim lrS1 As Long: lrS1 = wsS.Cells(wsS.Rows.count, "A").End(xlUp).Row + 1 Dim lrS2 As Long: lrS2 = wsS.Cells(wsS.Rows.count, "C").End(xlUp).Row + 1 Dim lrS3 As Long: lrS3 = wsS.Cells(wsS.Rows.count, "E").End(xlUp).Row + 1 With wsR Dim fRng As Range: Set fRng = .Range(.Cells(1, "A"), .Cells(lrR, "AN")) Dim rngN As Range: Set rngN = .Range(.Cells(2, "N"), .Cells(lrR, "N")) Dim rngY As Range: Set rngY = .Range(.Cells(2, "Y"), .Cells(lrR, "Y")) Dim cRng As Range: Set cRng = Union(rngN, rngY) End With fRng.AutoFilter field:=25, Criteria1:="<>", Operator:=xlFilterValues fRng.AutoFilter field:=1, Criteria1:="criteria1", Operator:=xlFilterValues If fRng.SpecialCells(xlCellTypeVisible).CountLarge > 2 Then

我在代码中所做的更改是移动；

Application.ScreenUpdating = False wsS.Rows("4:1048560").EntireRow.Delete Shift:=xlUp

上方；

Dim lrR As Long: lrR = wsR.Cells(wsR.Rows.count, "A").End(xlUp).Row Dim lrS1 As Long: lrS1 = wsS.Cells(wsS.Rows.count, "A").End(xlUp).Row + 1 ... ...

即删除必要的行后，然后定义和计算lr-s。

谢谢。

删除整行后，新复制的数据将向下移x行

1 个答案: