为了替代/variables为最大计数器？

我写了一个macros，它将三个单元格的string复制到一个标记的单元格中，并将它们粘贴到特定工作表中的下一个空行：

Sub testmacro_01() 'setting the variables Dim x As Integer Dim y As Integer Dim string1 As String Dim string2 As String Dim string3 As String 'setting start values x = 1 y = 1 string1 = "" string2 = "" string3 = "" 'checking for "m" in the "checkcolumn", if "m" then copy columns left to it: For x = 1 To 100 If ThisWorkbook.Sheets("testsheet").Cells(x, 4).Value = "m" _ Then string1 = ThisWorkbook.Sheets("testsheet").Cells(x, 1).Value string2 = ThisWorkbook.Sheets("testsheet").Cells(x, 2).Value string3 = ThisWorkbook.Sheets("testsheet").Cells(x, 3).Value 'checking for the next free line in "newsheet": Line1: If ThisWorkbook.Sheets("newsheet").Cells(y, 1).Value = "" _ And ThisWorkbook.Sheets("newsheet").Cells(y, 2).Value = "" _ And ThisWorkbook.Sheets("newsheet").Cells(y, 1).Value = "" _ Then 'pasting the strings into the free lines: ThisWorkbook.Sheets("newsheet").Cells(y, 1).Value = string1 ThisWorkbook.Sheets("newsheet").Cells(y, 2).Value = string2 ThisWorkbook.Sheets("newsheet").Cells(y, 3).Value = string3 Else 'if the checked line is full the search will go down by 1 line: y = y + 1 GoTo Line1 End If End If Next End Sub 

例如： 这是源表单

（应该复制到D列中标有字母“m”的行的每一行）

这是玩macros后的结果。

（具有灰色背景的单元在那里testing“下一个自由线function”）

这就是我被卡住的地方：虽然这个macros的工作原理和做它应该做的，我觉得它是相当静态的，可以做更多的“专业”。 我的重点在于“for to”循环： 如何将一个可变数字放在文本表格中的所有行中，而不是“100”？ 更改100到1000将适用于我的大部分应用程序，但似乎很保守。

Answer 1

循环一堆行有几种方法：

 'Find the first blank line r = 1 Do While Cells(r,1).Value <> "" r = r +1 Loop 

要么

LastRow = Cells.SpecialCells(xlCellTypeLastCell).Row

要么

LastRowColA = Range("A65536").End(xlUp).Row

要么

LastRow = Cells.Find("*",SearchOrder:=xlByRows,SearchDirection:=xlPrevious).Row

要么

LastRow = ActiveSheet.UsedRange.Rows.Count

---

并纠正GoTo和添加自定义filter

 strFilter = InputBox("Enter your copy criteria:") x = 1 'Start on row 1 and loop until the 1st blank line in Column A Do While Sheets("testsheet").Cells(x, 1).Value <> "" If Sheets("testsheet").Cells(x, 4).Value = strFilter Then With ThisWorkbook.Sheets("testsheet") string1 = .Cells(x, 1).Value string2 = .Cells(x, 2).Value string3 = .Cells(x, 3).Value End With With ThisWorkbook.Sheets("newsheet") y = .UsedRange.Rows.Count + 1 'We know this row is blank so skip all the code below ' If .Cells(y, 1).Value = "" And _ ' .Cells(y, 2).Value = "" And _ ' .Cells(y, 1).Value = "" _ ' Then 'pasting the strings into the free lines: .Cells(y, 1).Value = string1 .Cells(y, 2).Value = string2 .Cells(y, 3).Value = string3 End With ' There is no Else because we found our last row ' Else 'if the checked line is full the search will go down by 1 line: ' y = y + 1 ' GoTo Line1 ' End If End If x = x + 1 Loop 

Answer 2

这解决了你的大部分问题：

 Sub foo2() Dim ows As Worksheet Dim tws As Worksheet Dim rng As Range Dim lastrow As Long Dim twslastrow As Long Dim letr As String Set ows = Sheets("testsheet") Set tws = Sheets("newsheet") letr = "m" ' change this to reference what you want. twslastrow = tws.Cells.Find("*", tws.Range("A1"), , xlPart, xlByRows, xlPrevious, False).Row With ows lastrow = .Range("A" & .Rows.Count).End(xlUp).Row For Each rng In .Range(.Cells(2, 4), .Cells(lastrow, 4)) If rng.Value = letr Then Dim insertrow insertrow = tws.Evaluate("=MATCH(1,INDEX(($A$1:$A$" & twslastrow & "="""")*($C$1:$C$" & twslastrow & "="""")*($B$1:$B$" & twslastrow & "=""""),),0)") If IsError(insertrow) Then insertrow = tws.Cells.Find("*", tws.Range("A1"), , xlPart, xlByRows, xlPrevious, False).Row + 1 End If tws.Range(tws.Cells(insertrow, 1), tws.Cells(insertrow, 3)).Value = .Range(.Cells(rng.Row, 1), .Cells(rng.Row, 3)).Value End If Next rng End With End Sub