EXCEL中用VBA复制整行

Posted 2023-04-01

两个文件夹中的表复整行制（包括下拉列表，函数等全部）：表一和表二的A列是序号，想在表二中录入序号按回车就把表一序号所对应的一整行复制过来。谢谢
表中有自绘图形

这里假设表1的数据在A：H列
用函数可在表二的B1输入公式如下，公式右拉完成（A1输入序号）
=VLOOKUP($A1,Sheet1!$A:$H,COLUMN(),0)

如果用VBA实现，不管表1数据有几列，整行复制。代码如下：
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 And Target.Count = 1 Then
With Sheets("sheet1")
For x = 1 To .Range("A65536").End(xlUp).Row
If .Cells(x, 1) = Target.Value Then
.Rows(x).Copy Target.Rows
Exit Sub
End If
Next x
End With
End If
End Sub
把这代码放到表2的代码编辑框中即可实现你要的结果追问

请问指定表一路径的是哪一段代码？

追答

晕，搞错了，你是两个工作簿是吧？这个代码是在同一工作簿中的两个工作表的。

追问

是的，在这里我传不上附件，可加你QQ吗，我的451730539

追答

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Lj As String
Lj = "D:\我的文档\表2.xls"
If Target.Column = 1 And Target.Count = 1 Then
Workbooks.Open Lj
With Workbooks("表2.xls").Sheets("sheet1")
For x = 1 To .Range("A65536").End(xlUp).Row
If .Cells(x, 1) = Target.Value Then
.Rows(x).Copy Target.Rows
Exit Sub
End If
Next x
End With
Workbooks("表2.xls").Close True
End If
End Sub

追问

成功了，非常感谢，有一点我想改进，复制后希望返回的是表二，不是表一的结果

参考技术A 用 vlookup 函数。到Excel帮助中学习Ta的用法。 参考技术B 把表传上..追问

请问在这里怎样传表上来？

excel vba 代码求复制整行数据至其他表格中

判断表1的A列各单元格字体颜色是否为RGB(255,0,0)，如果是，复制整行数据到表2中

代码如下：

Sub 复制整行数据()
Dim I&, Rm&
Rm = Cells.Rows.Count
With Sheet1
   For I = 1 To .Range("A" & Rm).End(3).Row
      If .Range("A" & I).Font.Color = RGB(255, 0, 0) Then .Rows(I).Copy Sheet2.Range("A" & Rm).End(3).Offset(1)
   Next
End With
End Sub

参考技术A 以下代码你试试
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 '获取字体颜色
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
------代码结束-----------