无法停止从表单导入行的循环

我在循环中有一个问题。 我想在第一个单元格中导入包含“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