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列中标有字母“m”的每一行）

and this is the result after playing the macro.

（具有灰色背景的单元格用于测试“下一个自由线功能”）

这就是我被困的地方：虽然这个宏工作并且做它应该做的事情，但我觉得它是非常静态的，可以更“专业”地完成。我的重点是“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

对于最大计数器的替代/变量？

2 个答案: