記錄宏（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 

編輯 - 通過符號

列表添加循環