[已解决]江湖求救VBA解答，太难了

阿呆88

条件及要求已在附件中，VBA好难

最佳答案

月排行榜 / 总排行榜

wp8680

2014-7-1 14:59

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Dim x, rg As Range, rgs As Range, S1, S2
   
3.     If Target.Row = 1 Then
   
4.         If Target.Column = 8 Or Target.Column = 10 Then
   
5.             Range(Range("F4:i4"), Range("F4:i4").End(xlDown)).Clear
   
6.             x = Me.Range("a" & Cells.Rows.Count).End(xlUp).Row
   
7.             S1 = Me.[H1].Value
   
8.             S2 = Me.[J1].Value
   
9.             For Each rg In Me.Range("a2:a" & x)
   
10.                 If rg.Value = S1 And rg.Offset(0, 2).Value = S2 Then
    
11.                     If rgs Is Nothing Then Set rgs = rg.Resize(1, 4) Else Set rgs = Application.Union(rgs, rg.Resize(1, 4))
    
12.                 End If
    
13.             Next rg
    
14.             If rgs Is Nothing Then Exit Sub
    
15.             rgs.Copy
    
16.             Me.Range("f4").PasteSpecial
    
17.         End If
    
18.     End If
    
19. End Sub
    

复制代码

跳转到最佳答案楼层

JLxiangwei

这个还是简单吧，不难

阿呆88

JLxiangwei 发表于 2014-7-1 14:47
这个还是简单吧，不难

对我来说啊！呵

开心妙妙

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Dim i&, r&, n&
   
3.     If Target.Address = "$H$1" Or Target.Address = "$J$1" Then
   
4.         r = Range("F2").End(xlDown).Row
   
5.         If r > 3 Then Range("F4:I" & r).Clear
   
6.         r = Range("A65536").End(xlUp).Row
   
7.         For i = 2 To r
   
8.             If Range("A" & i) = Range("H1") And Range("C" & i) = Range("J1") Then
   
9.                 n = n + 1
   
10.                 Range("A" & i & ":D" & i).Copy Cells(3 + n, "F")
    
11.             End If
    
12.         Next i
    
13.     End If
    
14. End Sub

复制代码

求救（用VBA方法）.rar (25.03 KB, 下载次数: 12)

2014-7-1 14:57 上传

点击文件名下载附件

wp8680

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Dim x, rg As Range, rgs As Range, S1, S2
   
3.     If Target.Row = 1 Then
   
4.         If Target.Column = 8 Or Target.Column = 10 Then
   
5.             Range(Range("F4:i4"), Range("F4:i4").End(xlDown)).Clear
   
6.             x = Me.Range("a" & Cells.Rows.Count).End(xlUp).Row
   
7.             S1 = Me.[H1].Value
   
8.             S2 = Me.[J1].Value
   
9.             For Each rg In Me.Range("a2:a" & x)
   
10.                 If rg.Value = S1 And rg.Offset(0, 2).Value = S2 Then
    
11.                     If rgs Is Nothing Then Set rgs = rg.Resize(1, 4) Else Set rgs = Application.Union(rgs, rg.Resize(1, 4))
    
12.                 End If
    
13.             Next rg
    
14.             If rgs Is Nothing Then Exit Sub
    
15.             rgs.Copy
    
16.             Me.Range("f4").PasteSpecial
    
17.         End If
    
18.     End If
    
19. End Sub
    

复制代码

wp8680

求救（用VBA方法）.rar (26.17 KB, 下载次数: 23)

2014-7-1 15:00 上传

点击文件名下载附件

su45

都做好了呀？咱也做了个，试试：

求救（用VBA方法）.zip (25.58 KB, 下载次数: 20)

2014-7-1 15:24 上传

点击文件名下载附件

阿呆88

你试过你的吗？我刚试了下好像有点问题

QLZ0602

这样可以吗？

su45

阿呆88 发表于 2014-7-1 15:33
你试过你的吗？我刚试了下好像有点问题

你这是说谁呀？