在Excel中，每次使用范围内的值更改Excel中循环中的variables

我有下面的macros，通过数字1到17循环。问题是，数字不再是1到17，可能会再次改变，所以我想要一个工作表，这些数字是手动input一列，循环会然后对该列中的每个单元格值进行操作。

基本上，我想用一列中的范围的内容replace“J = 1到17”。

原文如下：

Sub Nottingham3() For j = 1 To 17 Dim LR As Long, i As Long Sheets("Stager").Cells.Clear With Sheets("basic list") On Error Resume Next LR = .Range("A" & Rows.Count).End(xlUp).Row For i = 1 To LR If .Range("A" & i).Value = j Then .Rows(i).Copy Destination:=Sheets("Stager").Range("A" & Rows.Count).End(xlUp).Offset(1) Next i End With NottsCopyData Next j End Sub 

没有什么我试过正在产生我需要的东西。

Answer 1

您可以使用此代替For / Next循环：

 Sub Nottingham3() Dim LR As Long, i As Long 'Put the dimensioning first Range("A1").Select 'Select the first cell of the column. Do j=Val(ActiveCell.Value) Sheets("Stager").Cells.Clear With Sheets("basic list") On Error Resume Next LR = .Range("A" & Rows.Count).End(xlUp).Row For i = 1 To LR If .Range("A" & i).Value = j Then .Rows(i).Copy Destination:=Sheets("Stager").Range("A" & Rows.Count).End(xlUp).Offset(1) Next i End With NottsCopyData ActiveCell.Offset(1).Activate 'Move one cell down Loop until ActiveCell.Value<>"" 'Check if cell still has number End Sub 

希望这可以帮助。

Answer 2

 j = 1 myCell = Cells(j, 1) Do While myCell.Value <> "" 'actions here j = j + 1 Loop 

Answer 3

要使用一系列的“过滤”值，你可能会像下面这样

 Sub Nottingham3() Dim dataRng As Range, filterRng As Range, cell As Range, found As Range Dim dataCols As Long 'set your variables once and for all With Sheets("basic list") Set dataRng = .Range("A1").CurrentRegion ' <== set data range dataCols = dataRng.Columns.Count Set filterRng = .Range("H3") '<== set the "filter" range first cell only. it'll be extended to its last non empty cell down the column Set filterRng = Range(filterRng, .Cells(.Rows.Count, filterRng.Column).End(xlUp)) 'resize filterrng End With For Each cell In dataRng Sheets("Stager").Cells.Clear 'not sure why clearing target sheet after every loop Set found = filterRng.Find(what:=cell.Value, LookIn:=xlValues, lookat:=xlWhole) 'check for the cell value in the filtering range If Not found Is Nothing Then cell.Resize(, dataCols).Copy Destination:=Sheets("Stager").Range("A" & Rows.Count).End(xlUp).Offset(1) ' if found, then copy relevant data only instead of the entire row NottsCopyData 'possibly a sub to process data in "Stager"? Next cell End Sub 

但也可以使用AdvancedFilter方法一次select和复制所有相关的数据行，如下所示

 Sub Nottingham4() Dim dataRng As Range, filterRng As Range, targetRng As Range 'define the targer range in "Stager" sheet With Sheets("Stager") .Cells.Clear Set targetRng = .Range("A" & .Rows.Count).End(xlUp) End With If Not IsEmpty(targetRng) Then Set targetRng = targetRng.Offset(1) 'if not the first row then skip one With Sheets("basic list") Set dataRng = .Range("A1").CurrentRegion ' <== set data range Set filterRng = .Range("H3") '<== set the first cell of the "filter" range. it'll be extended to its last non empty cell down the column 'insert "dummy" headers for exploiting AdvancedFilter() method With dataRng .Rows(1).Insert .Offset(-1).Resize(1).FormulaR1C1 = "=""Head"" & column()" End With Set dataRng = dataRng.Offset(-1).Resize(dataRng.Rows.Count + 1) 'resize data to include "dummy" headers With filterRng .Rows(1).Insert .Offset(-1) = "Head" & dataRng.Columns(1).Column 'fill filter range header accordingly End With Set filterRng = Range(filterRng.Offset(-1), .Cells(.Rows.Count, filterRng.Column).End(xlUp)) 'resize filterrng 'filter and copy and past to target cell dataRng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=filterRng, CopyToRange:=targetRng 'remove the "dummy" headers cells dataRng.Rows(1).Delete filterRng.Rows(1).Delete targetRng.EntireRow.Delete End With NottsCopyData 'possibly a sub to process ALL data in "Stager"? End Sub 

正如你所看到的，没有循环通过单元格，也没有多个复制和粘贴，所以它是非常快的，如果你必须处理大量的行

代码长度主要是为了“准备”的需要，因为实际的复制和粘贴只能由一个语句来完成，

 dataRng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=filterRng, CopyToRange:=targetRng 

当然，这一次操作可能需要在NottsCopyData子版本中进行一些修改（或者至less我假设它是一个子版本），它应该适用于处理由所有条件过滤的数据，而不是仅由一个条件

Answer 4

我在想，如果你使用了一个查找函数（这个列表在另一个表中，因为你可能不想复制列表和其他东西），你可以得到没有外部循环的相同结果：

 Sub Nottingham5() Dim result As Variant Dim LR As Long, i As Long Sheets("Stager").Cells.Clear With Sheets("basic list") LR = .Range("A" & Rows.Count).End(xlUp).Row For i = 1 To LR result = Application.VLookup(.Range("A" & i).Value, Sheets("lookup").Range("a:a"), 1, False) If Not IsError(result) Then .Rows(i).Copy Destination:=Sheets("Stager").Range("A" & Rows.Count).End(xlUp).Offset(1) Next i End With End Sub