Excel行粘贴与VBA

Question

大家好，我需要一些VBA的帮助。

我在表1中有来自单元格A6:O29的数字范围。接下来，我在表格3的"& & "栏中选择了特定的数字。

[![1]][1][![2]][2]

我想循环抛出表3列B中的每个值，并找到表1范围A6:O29中的特定值

接下来，它应该粘贴从表1中的整行，从表3中的列(Q:CF)开始，从C列开始

我已经编码了，但是它不工作。

Private Sub CommandButton1_Click()

Dim main As Worksheet
Dim outcome As Worksheet

'main sheet contains Range to search number in
Set main = ThisWorkbook.Sheets("Sheet1")

'outcome sheet has specific values in Column B
Set outcome = ThisWorkbook.Sheets("Sheet3")

'column B values are considrered as doubles
Dim valuesfind As Double

'range where values are to be found 
Dim myrange As Range

Set myrange = Worksheets("Sheet1").Range("A6:O29")

'no of times to loop code based on values in outcomesheet
locations = Worksheets("Sheet3").Cells(Rows.Count, 2).End(xlUp).Row

For i = 6 To locations
degrees = outcome.Range("B" & i).Value

For b = 6 To Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

If main.Range("A6:O29" & b).Value = degrees Then
outecome.Range("C:BR" & i).Value = main.Range("Q:CF" & b).Value
Exit For
End If
Next b
Next i
End Sub


[1]: https://i.stack.imgur.com/uBo66m.png
[2]: https://i.stack.imgur.com/D0bRUm.png

Answer 1

请记住声明所有变量，在模块顶部添加Option Explicit以帮助您强制执行。

试试下面的代码:

Option Explicit
Private Sub CommandButton1_Click()

'main sheet contains Range to search number in
Dim main As Worksheet
Set main = ThisWorkbook.Sheets("Sheet1")
Const mainCopyRng As String = "Q?:CF?"

'outcome sheet has specific values in Column B
Dim outcome As Worksheet
Set outcome = ThisWorkbook.Sheets("Sheet3")
Const outcomePasteRng As String = "C?:BR?"

'range where values are to be found
Dim myrange As Range
Set myrange = main.Range("A6:O29")

'no of times to loop code based on values in outcomesheet
Dim outcomeLastRow As Long
outcomeLastRow = outcome.Cells(Rows.Count, 2).End(xlUp).Row

Dim i As Long
For i = 6 To outcomeLastRow
Dim Degrees As Double
Degrees = outcome.Cells(i, 2).Value

Dim searchRng As Range
Set searchRng = myrange.Find(Degrees, LookIn:=xlValues, LookAt:=xlWhole)
If Not searchRng Is Nothing Then
Dim searchRow As Long
searchRow = searchRng.Row

outcome.Range(Replace(outcomePasteRng, "?", i)).Value = main.Range(Replace(mainCopyRng, "?", searchRow)).Value
End If
Next i
End Sub

Answer 2

应该可以。

Sub Test()
Dim main As Worksheet
Set main = ThisWorkbook.Sheets("Sheet1")

Dim myrange As Range
Set myrange = main.Range("A6:O29")

Dim outcome As Worksheet
Set outcome = ThisWorkbook.Sheets("Sheet3")

'Set reference to locations in sheet3.
Dim locations As Range
With outcome
Set locations = .Range(.Cells(1, 2), .Cells(Rows.Count, 2).End(xlUp))
End With

'Search for each location in Sheet1 and if found copy to Sheet3.
Dim location As Range
Dim FoundLocation As Range
For Each location In locations
Set FoundLocation = myrange.Find( _
What:=location, _
After:=myrange.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext)

If Not FoundLocation Is Nothing Then
main.Cells(FoundLocation.Row, 1).Resize(, 15).Copy _
Destination:=location.Offset(, 1)
End If
Next location
End Sub