Question

我在循环中遇到问题。我想在第一个单元格中导入包含“X”的行，但是：

它不会从第一行粘贴它们
它粘贴太多次

有人可以帮助我吗？

 Sub refresh()
    '
    ' refresh Macro
    '
    ' Touche de raccourci du clavier: Ctrl+y
    '
    Dim LastRow As Integer, i As Integer
    Dim wksSrc As Worksheet, wksDest As Worksheet
    Dim lngRow As Long

    Set wksSrc = ThisWorkbook.Worksheets("Scénarios de menace")
    Set wksDest = ThisWorkbook.Worksheets("Analyse de risque S")
    Application.Calculation = xlAutomatic
    Application.DisplayAlerts = False
    wksDest.Range("A6:AP1000").Delete
    Application.DisplayAlerts = True
    wksDest.Range("A6:AP1000").ClearContents 'Works directly, without selection

    lngRow = wksDest.Cells(wksDest.Rows.Count, 2).End(xlUp).Row + 1

    For i = 2 To wksSrc.Range("A" & wksSrc.Rows.Count).End(xlUp).Row

      If wksSrc.Cells(i, 1) = "X" Then
        wksSrc.Range(wksSrc.Cells(i, 2), wksSrc.Cells(i, 20)).Copy

        wksDest.Range("B" & lngRow).PasteSpecial xlPasteValuesAndNumberFormats
        Application.CutCopyMode = False
        lngRow = lngRow + 1
      End If
    Next i
End Sub

Answer 1

sub refresh()    
Dim LastRow As Integer, i As Integer
Dim wksSrc As Worksheet, wksDest As Worksheet
Dim lngRow As Long

Set wksSrc = ThisWorkbook.Worksheets("Scénarios de menace")
Set wksDest = ThisWorkbook.Worksheets("Analyse de risque S")

wksDest.Range("A6:AP1000").Delete
wksDest.Range("A6:AP1000").ClearContents 'Works directly, without selection

lngRow = 6
LastRow = wksSrc.Range("A" & wksSrc.Rows.Count).End(xlUp).Row

For i = 2 To LastRow

  If wksSrc.Cells(i, 1) = "X" Then
    wksSrc.Range(wksSrc.Cells(i, 2), wksSrc.Cells(i, 20)).Copy
    wksDest.Range("B" & lngRow).PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
    lngRow = lngRow + 1
  End If
Next i
end sub

Answer 2

此版本已优化（不使用For循环）

Option Explicit

Public Sub refreshAnalyse()
    Dim ws1 As Worksheet, ws2 As Worksheet, lr1 As Long

    Set ws1 = ThisWorkbook.Worksheets("Scénarios de menace")
    Set ws2 = ThisWorkbook.Worksheets("Analyse de risque S")

    ws2.Range("B6:AP" & ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row).Clear
    lr1 = ws1.Cells(ws1.Rows.Count, 2).End(xlUp).Row

    Application.ScreenUpdating = False
        ws1.Range("A1:A" & lr1).AutoFilter Field:=1, Criteria1:="x"
        ws1.Range("B2:AP" & lr1).SpecialCells(xlCellTypeVisible).Copy

        ws2.Range("B6").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        ws1.Range("A6:A" & lr1).AutoFilter
        ws2.Activate: ws2.Cells(1, 1).Activate
    Application.ScreenUpdating = True
End Sub

无法停止将行从工作表导入到另一个工作表的循环

2 个答案: