如果字符串在另一个工作表上匹配，则从范围复制行

Question

我正试图从范围E3:H复制仅行(而不是整个行)，直到使用列H:H作为参数从表test1结束，以检查在单元格D1上表test2上的字符串是否匹配

例如。:如果在表test2中，单元格D1的值为dog，则必须复制sheet1的C3:H范围内的所有行，并使用sheet1的H3:H列作为参数(如果某些行中存在dog)。因此，它应该复制表test2在M3

列中的匹配行嗯，这对我来说很难。有人能帮忙吗?

谢谢

Sub Test()
Dim rw As Long, Cell As Range
LastRow = Sheets("test1").Range("H" & Rows.Count).End(xlUp).Row

For Each Cell In Sheets("test1").Range("H:H")
rw = Cell.Row
If Cell.Value = "D1" Then 'How do i define to take the value `D1` from sheet `test2`?
Cell.Range("E3:H" & LastRow).Copy
Sheets("test2").Range("M3:M" & LastRow & rw).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
Next
End Sub

Answer 1

这应该可以，测试一下让我知道你是怎么做的

注意:有更有效的方法来做到这一点，但希望这更容易遵循，应该足够快

Sub Test()
Dim rw As Long, rng As Range, ws As Worksheet
Set ws = ThisWorkbook.Sheets("sheet1")
LastRow = ws.Range("H" & Rows.Count).End(xlUp).Row
Dog = Sheets("test2").Range("D1").Value
i = 3

For Each rng In ws.Range("H3:H" & LastRow)
rw = rng.Row
If rng.Value = Dog Then
Sheets("test2").Range("M" & i & ":R" & i).Value = ws.Range("C" & rw & ":H" & rw).Value
i = i + 1
End If
Next rng
End Sub

Answer 2

复制行

• 这是一个基本代码。通过赋值复制(drrg.Value = srrg.Value)而不是使用PasteSpecial xlPasteValues是提高效率的唯一实现。

Option Explicit
Sub CopyRows()

' 1. Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code

' 2. Source

' Reference the source worksheet ('sws').
Dim sws As Worksheet: Set sws = wb.Worksheets("Test1")
' Calculate the source last row ('slRow'),
' the row of the last non-empty cell in the column.
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "H").End(xlUp).Row
' Reference the source columns range ('scrg') whose rows will be copied.
Dim scrg As Range: Set scrg = sws.Columns("E:H")

' 3. Destination

' Reference the destination worksheet ('dws').
Dim dws As Worksheet: Set dws = wb.Worksheets("Test2")
' Reference the first destination row range by resizing the first
' destination cell by the number of columns of the source columns range.
Dim drrg As Range: Set drrg = dws.Range("M3").Resize(, scrg.Columns.Count)
' Write the lookup string value to a string variable ('dlString').
Dim dlString As String: dlString = CStr(dws.Range("D1").Value)

' 4. The Loop

' Declare additional variables.
Dim srrg As Range ' Current Source Row Range
Dim sr As Long ' Current Row in the Source Worksheet
Dim slString As String ' Current String Lookup String

' Loop through the designated rows of the source worksheet.
For sr = 3 To slRow
' Write the source string value in the current row to a variable.
slString = CStr(sws.Cells(sr, "H").Value)
' Compare the string in the current row against the lookup string.
' The comparison is case-insensitive i.e. 'dog = DOG'
' due to the 'vbTextCompare' parameter.
If StrComp(slString, dlString, vbTextCompare) = 0 Then ' is equal
' Reference the source row range.
Set srrg = scrg.Rows(sr)
' Write the values from the source row range
' to the destination row range ('copy by assignment').
drrg.Value = srrg.Value
' Reference the next destination row range (one row below).
Set drrg = drrg.Offset(1)
'Else ' is not equal; do nothing
End If
Next sr

' 5. Inform to not wonder if the code has run or not.
MsgBox "Rows copied.", vbInformation

End Sub