如何用vba代码查找并提取相对应的整行数据到新的工作表中，部分按行排，部分转置为列。

Question

具体说明：Sheet1是原始数据，现在想在sheet2中的A2单元格内输入sheet1中首列的某ID号，实现提取该ID号所在行内各订户的数据转置到sheet2的B列中（从B4开始往下排）；品名和单价提取到第二行内（从B2往右排）。请高手帮忙。

Answer 1

在sheet2 的工作表标签上点击右键选查看代码,然后粘贴下面的代码,然后保存.返回sheet2工作表.只要在A2单元格输入有效的数据,就可以自动返回你要的结果.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address(0, 0) = "A2" Then
endrow = Sheet1.Range("A65536").End(xlUp).Row
endcol = Sheet1.Range("iv1").End(xlToLeft).Column
With Sheet1
Set arr = .Range(.Cells(2, 1), .Cells(endrow, endcol))
End With
Target.Offset(2, 0).Resize(endcol - 3, 1) = Application.WorksheetFunction.Transpose(Sheet1.Range("d1:R1"))
Target.Offset(-1, 0).Resize(1, 3) = Sheet1.Range("A1:C1").Value
iarr = Split("订户,数量,金额", ",")
Target.Offset(1, 0).Resize(1, 3) = iarr
For i = 1 To endrow
If arr(i, 1) = Target.Value Then
Target.Offset(0, 1) = arr(i, 2)
Target.Offset(0, 2) = arr(i, 3)
ReDim Myarr2(endcol - 3)
For ii = 1 To endcol - 3
Myarr2(ii - 1) = arr(i, ii + 3)
Next ii
Target.Offset(2, 1).Resize(endcol - 3, 1) = Application.WorksheetFunction.Transpose(Myarr2)
Exit For
End If
Next
End If
End Sub追问

感谢你的回答。当粘贴代码后，出现了：运行时错误‘1004’应用程序定义或对象定义错误，
调试时：Target.Offset(2, 0).Resize(endcol - 3, 1) = Application.WorksheetFunction.Transpose(Sheet1.Range("d1:R1"))这行代码为黄色。劳驾你，能否解决？

追答

我这里测试没有问题阿,我的测试环境是excel 2003.
你检查一下你的sheet1的第一行的内容是标题行吗?
如果不是那么
endcol = Sheet1.Range("iv1").End(xlToLeft).Column
就不是正确的最大列号.
如果sheet1的第一行是空行的话 会引起你说的错误.解决的办法 是修改
endcol = Sheet1.Range("iv1").End(xlToLeft).Column
把iv1改成有完整数据的行号.比如改成iv5 就是在第五行获取正确的最大列号.

追问

非常感谢您的帮助。运行正常了，问题正如您所述。目前还有两个问题烦请您赐教：1.在A2中输入sheet1中存在的正确ID代码，必须敲回车再返回A2，数据才能更新。能否实现敲回车数据更新？2、在A2中输入sheet1中不存在的ID代码，数据不更新，此状况时，能否实现 “该ID不存在”的提示框给予提醒；或者“品名、单价、数量”的对应数据框内为“空值”？谢谢！

追答

抱歉,没注意选错触发事件的类型了.用下面的代码.应该可以解决你说的两个问题
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) = "A2" Then
endrow = Sheet1.Range("A65536").End(xlUp).Row
endcol = Sheet1.Range("iv1").End(xlToLeft).Column
With Sheet1
Set arr = .Range(.Cells(2, 1), .Cells(endrow, endcol))
End With
Target.Offset(2, 0).Resize(endcol - 3, 1) = Application.WorksheetFunction.Transpose(Sheet1.Range("d1:R1"))
Target.Offset(-1, 0).Resize(1, 3) = Sheet1.Range("A1:C1").Value
Target.Offset(0, 1) = ""
Target.Offset(0, 2) = ""
Target.Offset(2, 1).Resize(endcol - 3, 1) = ""
iarr = Split("订户,数量,金额", ",")
Target.Offset(1, 0).Resize(1, 3) = iarr

For i = 1 To endrow
If arr(i, 1) = Target.Value Then
Target.Offset(0, 1) = arr(i, 2)
Target.Offset(0, 2) = arr(i, 3)
ReDim Myarr2(endcol - 3)
For ii = 1 To endcol - 3
Myarr2(ii - 1) = arr(i, ii + 3)
Next ii
Target.Offset(2, 1).Resize(endcol - 3, 1) = Application.WorksheetFunction.Transpose(Myarr2)
Exit For
End If
Next

End If
End Sub

Answer 2

用vlookup函数实现。