для альтернативного/переменного для максимального счетчика?

Question

Я написал макрос, который Копирует строку из трех клеток, оставшихся к заметному клетки и пастам те к следующей свободной строке в определенном листе:

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 

Например: This is the source sheet

(каждая линия слева линия, обозначенная буква «м» в колонке D должна быть скопирована)

and this is the result after playing the macro.

(клетки с серым фоном существует, чтобы т est «следующая функция свободной линии»)

Вот где я застрял: Пока этот макрос работает и делает то, что он должен делать, я чувствую, что он довольно статичен и может быть сделан более «профессионально». Я сосредоточен здесь на цикле «for to»: Как поместить переменное число, которое всегда будет включать все существующие строки в текстовом листе в цикл for for вместо «100»? Изменение 100 до 1000 будет работать для большинства моих приложений, но кажется очень ханжеским.

Answer 1

Это решает большинство ваших проблем:

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 

Answer 2

Есть несколько способов перекручивание через кучу строк:

'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 и добавление пользовательского фильтра

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