如何用<em>VBA</em>去实现<em>EXCEL</em>的表中找

以下代码你试试
sheet1 是判断的工作表 改成你自己的
sheet2 是粘贴的工作表 改成你自己的
------代码开始-------
Sub 判断复制()
Dim a%, b, c
Do
b = b + 1 '行数累加
If Sheets("Sheet1").Cells(b, 1) = "" Then Exit Do '判断单元格是否为空，为空时结束代码运行 也可以改成行数多少时结束如:if B>100 then exit sub
a = Cells(b, 1).Font.ColorIndex '获取字体颜色e79fa5e98193e58685e5aeb9362
If a = 3 Then '判断字体颜色是否为红色（VBA中红色是3/excel中RGB(255,0,0)是红色）
Sheets("Sheet1").Select '选中工作表
Rows(b & ":" & b).Select '判断正确选择该行
Selection.Copy '复制
Sheets("sheet2").Select '选择sheet2工作表（sheet2可以更改为其它工作表）
Range("A65536").Select
Selection.End(xlUp).Select
c = ActiveCell.Row + 1
Range("A" & c).Select '选中最后使用单元格的下一个A列的值
ActiveSheet.Paste '粘贴
Sheets("Sheet1").Select '选中判断条件的单元格
End If
Loop
Sheets("Sheet2").Select
Application.CutCopyMode = False
End Sub
------代码结束-----------

给你一个工作表事件代码，你可以参考使用e799bee5baa6e997aee7ad94e59b9ee7ad94332:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
On Error Resume Next
Dim a As String， b As String， x As Integer， y As Integer
Dim rng As Range
y = Sheets(3).[a65536].End(3).Row
If Target <> "" And Target.Column = 1 Then
a = "*" & Target & "*"
With Sheets(2)
For Each rng In .UsedRange
If rng Like a = True Then
x = rng.Row
y = y + 1
.Range(x & ":" & x).Copy Destination:=Sheets(3).Range("A" & y)
End If
Next
End With
End If
Application.ScreenUpdating = True
End Sub
这个代码的功能是在表1的A列输入数值，自动查找表二中对应A列数值然后事先复制到表三。

欢迎到Excel Home论坛学习、交流”。

sub fuzhi()
 dim rng as range
 set rng=nonthing
  sheets("分析道").rows("2:5000").clearcontents
  for i=5 to sheets("数据版权").range("AD65536").end(Xlup).row
    if sheets("数据").cells(i,"AD") like "*异常*" then 
      if rng is nothing then 
       set rng = Sheets("数据").rows(i)
      else 
       set rng =union(rng, Sheets("数据").rows(i))
       end if
    end if
   next
   rng.copy sheets("分析").[a2]
 end sub

Sub LKJLK()
    Application.ScreenUpdating = False
    Workbooks.Open Filename:=ThisWorkbook.Path & "\b.xls"
    Set tbs = ThisWorkbook.Sheets(1)
    fa = tbs.[b1]
    Set wb = ActiveWorkbook
    For st = 1 To wb.Sheets.Count
        Set ss = Sheets(st)
        xr = ss.[a65536].End(3).Row
        For x = 1 To xr
            Set ff = ss.Range(ss.Cells(x, 1), ss.Cells(x, "iv")).Find(What:=fa, MatchCase:=True)
            If Not ff Is Nothing Then
            ss.Rows(x & ":" & x).Copy tbs.Range("a" & tbs.[a65536].End(3).Row + 1)
            End If
        Next
    Next
    ActiveWindow.Close
    Application.ScreenUpdating = True
End Sub

大概就这样吧，没附件，A/B两个工作薄放在同一目录下，代码放在A工作薄中，工作薄的第7a64e4b893e5b19e337一个工作表的B1单元格内容为要查找的内容，B工作薄为数据源