Question

这里的VBA并不是很擅长。找到并编辑了一些我认为可以帮助我的代码。我需要此代码来搜索2列（L和M），查找以_LC _LR等结尾的那些列中的任何字符串...示例：xxxxxxxx_LC。如果单元格以数组中的任何内容结尾，我需要将行复制到新工作表中。这就是我所拥有的：

 Option Explicit

Sub Test()

Dim rngCell As Range
Dim lngLstRow As Long
Dim keywords() As String
Dim maxKeywords As Integer


maxKeywords = 6
ReDim keywords(1 To maxKeywords)

maxKeywords(1) = "_LC"
maxKeywords(2) = "_LR"
maxKeywords(3) = "_LF"
maxKeywords(4) = "_W"
maxKeywords(5) = "_R"
maxKeywords(6) = "_RW"

lngLstRow = ActiveSheet.UsedRange.Rows.Count

For Each rngCell In Range("L2:L, M2:M" & lngLstRow)
    For i = 1 To maxKeywords
            If keywords(i) = rngCell.Value Then
                rngCell.EntireRow.Copy
                    Sheets("sheet1").Select
                        Range("L65536, M65536").End(xlUp).Offset(1, 0).Select
                        Selection.PasteSpecial xlPasteValues
                    Sheets("Results").Select

            End If
        Next i
Next

End Sub

Answer 1

好的，我认为问题在于您的变量声明。在继续之前，我将回应@ GradeEhBacon的评论，如果你无法阅读并理解发生了什么，你可能需要花一些时间来学习VBA才能运行。

这应该有效，AFAIK。您没有指定哪个工作表具有哪些信息，因此可能需要进行调整。试试下面的内容，让我知道什么是/不工作：

Sub Test()

Dim rngCell As Range
Dim lngLstRow As Long
Dim keywords() As String, maxKeywords() As String
Dim totalKeywords As Integer, i&
Dim ws As Worksheet, resultsWS As Worksheet

Set ws = Sheets("Sheet1")
Set resultsWS = Sheets("Results")

totalKeywords = 6
ReDim keywords(1 To totalKeywords)
ReDim maxKeywords(1 To totalKeywords)

maxKeywords(1) = "_LC"
maxKeywords(2) = "_LR"
maxKeywords(3) = "_LF"
maxKeywords(4) = "_W"
maxKeywords(5) = "_R"
maxKeywords(6) = "_RW"

 lngLstRow = ws.UsedRange.Rows.Count  'Assuming "Sheet1" is what you want to get the last range of.

Dim k&                       ' create a Long to use as Column numbers for the loop
For k = 12 To 13             ' 12 is column L, 13 is M
    With ws                  'I'm assuming your Ranges are on the "Sheet1" worksheet
        For Each rngCell In .Range(.Cells(1, k), .Cells(lngLstRow, k))
            For i = LBound(maxKeywords) To UBound(maxKeywords)
                If maxKeywords(i) = Right(rngCell.Value, 3) or maxKeywords(i) = Right(rngCell.Value, 2) Then
                    ' rngCell.EntireRow.Copy
                    ' ws.Range("L65536, M65536").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                    resultsWS.Cells(65536, k).End(xlUp).Offset(1, 0).EntireRow.Value = rngCell.EntireRow.Value
                End If
            Next i
        Next rngCell
    End With
Next k
End Sub

Answer 2

这可能就是你要找的东西：

=============================================== ===

Option Explicit

Sub Test()

Dim rngCell As Range
Dim lngLstRow As Long
Dim keywords() As String
Dim maxKeywords, i, j, k As Integer


maxKeywords = 6
ReDim keywords(1 To maxKeywords)

keywords(1) = "_LC"
keywords(2) = "_LR"
keywords(3) = "_LF"
keywords(4) = "_W"
keywords(5) = "_R"
keywords(6) = "_RW"

lngLstRow = ActiveSheet.UsedRange.Rows.Count

For j = 1 To lngLstRow
  For i = 1 To maxKeywords
    If keywords(i) = Right(Sheets("Results").Range("L" & j).Value,     Len(keywords(i))) Or _
      keywords(i) = Right(Sheets("Results").Range("M" & j).Value, Len(keywords(i))) Then
        k = k + 1
          Rows(j & ":" & j).Copy
            Sheets("sheet1").Select
              Range("A" & k).Select
                ActiveSheet.Paste
    End If
  Next i
Next j

End Sub

字符串的VBA搜索列和复制行到新工作表

2 个答案: