[已解决]同项不同组数据复制

cyj153 · 发表于 2011-10-30 13:36

本帖最后由 cyj153 于 2011-10-30 13:37 编辑

同项不同组数据复制.rar (13.12 KB, 下载次数: 14)

爱疯 · 发表于 2011-10-30 13:54

Sub 按钮2_Click()
Dim A, B(1 To 65555, 1 To 4), x%, y%, i&, s&
With Sheets(3)
A = .Range("a2:h" & .Range("a2").End(xlDown).Row)
End With
With Sheets(1)
x = .Range("m2")
y = .Range("o2")
End With
For i = 1 To UBound(A)
If A(i, 1) = x And A(i, 4) = y Then
s = s + 1
B(s, 1) = s
B(s, 2) = A(i, 6)
B(s, 3) = A(i, 7)
B(s, 4) = A(i, 8)
End If
Next i
With Sheets(2)
.Range("a4:e65536").Clear
If s > 0 Then
Sheets(2).Range("a4").Resize(s, 4) = B
End If
End With
End Sub

复制代码

同项不同组数据复制2.rar (13.17 KB, 下载次数: 13)

cyj153 · 发表于 2011-10-30 18:09

回复爱疯的帖子

太感谢了，解决了！

cyj153 · 发表于 2011-10-30 14:37

回复爱疯的帖子

是这样，谢爱疯师。两个问题都解决了。谢谢！

cyj153 · 发表于 2011-10-30 16:46

本帖最后由 cyj153 于 2011-10-30 16:47 编辑

回复爱疯的帖子

爱疯师，您好！请教个问题，我把表3的P列也复制到表2的G列，修改代码后为什么会出现下标越界，错在哪里，请指教！谢谢。

Sub 按钮2_Click()
Dim A, B(1 To 65555, 1 To 16), x%, y%, i&, s&
With Sheets(3)
A = .Range("a2:h" & .Range("a2").End(xlDown).Row)
End With
With Sheets(1)
x = .Range("m2")
y = .Range("o2")
End With
For i = 1 To UBound(A)
If A(i, 1) = x And A(i, 4) = y Then
s = s + 1
B(s, 1) = s
B(s, 2) = A(i, 6)
B(s, 3) = A(i, 7)
B(s, 4) = A(i, 8)
B(s, 7) = A(i,16)
End If
Next i
With Sheets(2)
.Range("a4:e65536").Clear
If s > 0 Then
Sheets(2).Range("a4").Resize(s, 7) = B
End If
End With
End Sub

爱疯 · 发表于 2011-10-30 17:20

Sub 按钮2_Click()
Dim A, B(1 To 65555, 1 To 7), x%, y%, i&, s&
With Sheets(3)
      A = .Range("a2:p" & .Range("a2").End(xlDown).Row)
End With
With Sheets(1)
      x = .Range("m2")
      y = .Range("o2")
End With
For i = 1 To UBound(A)
      If A(i, 1) = x And A(i, 4) = y Then
         s = s + 1
         B(s, 1) = s
         B(s, 2) = A(i, 6)
         B(s, 3) = A(i, 7)
         B(s, 4) = A(i, 8)
         B(s, 7) = A(i, 16)
      End If
Next i
With Sheets(2)
      .Range("a4:e65536").Clear
      If s > 0 Then
         Sheets(2).Range("a4").Resize(s, 7) = B
      End If
End With
End Sub

修改了两处。
因为看不到实际效果，所以不知这么改行吗

		自动登录	找回密码
密码			注册