[已解决]求助一段代码

lh442246

Book1.rar (3.73 KB, 下载次数: 8)

2014-6-30 14:59 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

云影

2014-6-30 15:13

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Dim arr, x, y
   
3.     If Target.Column <> 1 Then Exit Sub
   
4.     arr = Sheet1.Range("a1").CurrentRegion
   
5.     For x = 2 To UBound(arr)
   
6.         If Target.Value = arr(x, 1) Then
   
7.             For y = 2 To 6
   
8.                 Cells(Target.Row, y) = arr(x, y)
   
9.             Next
   
10.         End If
    
11.     Next
    
12. End Sub
    

复制代码

跳转到最佳答案楼层

xdragon

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.    Dim irow&, rng As Range
   
3.    If Target.Count = 1 Then
   
4.      If Target.Column = 1 Then
   
5.         With Sheets("合同资料")
   
6.            Set rng = .Columns(1).Find(Target.Value, , xlValues, xlWhole)
   
7.            If Not rng Is Nothing Then
   
8.               irow = rng.Row
   
9.               Target.Offset(, 1).Resize(, 5) = .Range("B" & irow & ":F" & irow).Value
   
10.            Else
    
11.               Target.Offset(, 1).Resize(, 5).ClearContents
    
12.            End If
    
13.         End With
    
14.      End If
    
15.    End If
    
16. End Sub

复制代码

云影

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Dim arr, x, y
   
3.     If Target.Column <> 1 Then Exit Sub
   
4.     arr = Sheet1.Range("a1").CurrentRegion
   
5.     For x = 2 To UBound(arr)
   
6.         If Target.Value = arr(x, 1) Then
   
7.             For y = 2 To 6
   
8.                 Cells(Target.Row, y) = arr(x, y)
   
9.             Next
   
10.         End If
    
11.     Next
    
12. End Sub
    

复制代码

baksy

公式解决；
B4单元格复制以下公式，横拉、下拉。
=IF($A4="","",VLOOKUP($A4,合同资料!$A$2:$F$4,COLUMN(),0))

ppp710715

是否这样 Book000.rar (8.97 KB, 下载次数: 1)

2014-6-30 15:16 上传

点击文件名下载附件

lh442246

谢谢各老师。5楼的出现报错，其他的都好用。