记录宏（Excel 2003）按行有条件地复制粘贴

Question

我每天都会从外部来源输入数据。在一张纸上，我有一个股票代码列表（按字母顺序排列），并在该行中继续显示相应的数据。

在另一张纸上，我有股票按其相应的部门组织，而不是按字母顺序排列。

我试图开发一个宏，使第一张工作表中的信息自动粘贴到第二张工作表中，方法是识别代码并粘贴到相应的行中。

这里是到目前为止所使用的代码，但它没有工作打算的方式：

Dim LSymbol As String 
    Dim LRow As Integer 
    Dim LFound As Boolean 

    On Error GoTo Err_Execute 

    'Retrieve symbol value to search for 
    LSymbol = Sheets("Portfolio Update").Range("B4").Value 

    Sheets("Test").Select 

    'Start at row 2 
    LRow = 2 
    LFound = False 

    While LFound = False 

     'Encountered blank cell in column B, terminate search 
     If Len(Cells(2, LRow)) = 0 Then 
      MsgBox "No matching symbol was found." 
      Exit Sub 

     'Found match in column b 
     ElseIf Cells(2, LRow) = LSymbol Then 

      'Select values to copy from "Portfolio Update" sheet 
      Sheets("Portfolio Update").Select 
      Range("B5:V5").Select 
      Selection.Copy 

      'Paste onto "Test" sheet 
      Sheets("Test").Select 
      Cells(3, LRow).Select 
      Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ 
      False, Transpose:=False 

      LFound = True 
      MsgBox "The data has been successfully copied." 

     'Continue searching 
     Else 
      LRow = LRow + 1 
     End If 

    Wend 

    On Error GoTo 0 

    Exit Sub 

Err_Execute: 
    MsgBox "An error occurred." 

End Sub 

感谢。

Answer 1

应该是.Cells(row,col) not .Cells（列，行）`

但是，您可以通过使用find（）避免循环 -

Sub Tester() 

    Dim LSymbol As String 

    Dim shtPU As Worksheet 
    Dim shtTest As Worksheet 
    Dim f As Range 
    Dim c As Range 

    Set shtPU = Sheets("Portfolio Update") 
    Set shtTest = Sheets("Test") 

    On Error GoTo Err_Execute 

    For Each c In shtPU.Range("B4:B50").Cells 

     LSymbol = c.Value 'Retrieve symbol value to search for 

     If Len(LSymbol) > 0 Then 
      Set f = shtTest.Columns(2).Find(LSymbol, , xlValues, xlWhole) 
      If Not f Is Nothing Then 
       'was found 
       With c.Offset(0, 1).Resize(1, 21) 
        f.Offset(0, 1).Resize(1, .Columns.Count) = .Value 
       End With 
       c.Interior.Color = vbGreen 
       'MsgBox "The data has been successfully copied." 
      Else 
       'not found 
       c.Interior.Color = vbRed 
       'MsgBox "No matching symbol was found." 
      End If 
     End If 

    Next c 

    Exit Sub 

Err_Execute: 
    MsgBox "An error occurred:" & Err.Description 

End Sub 

编辑 - 通过符号

列表添加循环