Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2535|回复: 9

[已解决]满足2个条件就粘贴到另外的工作簿

[复制链接]
发表于 2014-4-9 08:56 | 显示全部楼层 |阅读模式
本帖最后由 zss7758258 于 2014-4-9 10:32 编辑

5555.JPG
555.zip (73.19 KB, 下载次数: 6)
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2014-4-9 09:02 | 显示全部楼层
回复

使用道具 举报

 楼主| 发表于 2014-4-9 09:02 | 显示全部楼层
hwc2ycy 发表于 2014-4-9 09:02
是复制所在行的数据到表中不?

是的
回复

使用道具 举报

发表于 2014-4-9 09:35 | 显示全部楼层
  1. Sub test()
  2.     Dim rgh2, rgi2$
  3.     Dim arr
  4.     Dim i&
  5.     If Len(Range("h2").Value) = 0 Or Len(Range("i2").Value) = 0 Then Exit Sub
  6.     rgh2 = Range("h2")
  7.     rgi2 = "*" & rgi2 & "*"
  8.     Dim wb As Workbook
  9.     Set wb = GetObject(ThisWorkbook.Path & "\文件2.xlsx")
  10.     arr = Range("a1").CurrentRegion.Value
  11.     For i = 2 To UBound(arr)
  12.         If arr(i, 1) = rgh2 Then
  13.             If arr(i, 3) Like rgi2 Then
  14.                 Application.ScreenUpdating = False
  15.                 With wb
  16.                     With .Worksheets("表222")
  17.                         Cells(i, 1).Resize(, UBound(arr)).Copy .Cells(Rows.Count, 1).End(xlUp).Offset(1)
  18.                     End With
  19.                 End With
  20.             End If
  21.         End If
  22.     Next
  23.     With wb
  24.     Windows(.Name).Visible = True
  25.     .Close True
  26.     End With
  27.     Application.ScreenUpdating = True
  28. End Sub
复制代码
添加个按钮,指定宏。
回复

使用道具 举报

发表于 2014-4-9 09:42 | 显示全部楼层
文件1.rar (21.34 KB, 下载次数: 5)
回复

使用道具 举报

发表于 2014-4-9 09:42 | 显示全部楼层
  1. Sub test()
  2.     Dim arr, brr(), str_Path$, k%, i%, n%, m%, wk As Workbook
  3.     arr = Range("a1").CurrentRegion
  4.     For k = 2 To UBound(arr)
  5.         If arr(k, 1) = Range("h2") And InStr(arr(k, 3), Range("i2")) > 0 Then
  6.             n = n + 1
  7.             ReDim Preserve brr(1 To UBound(arr, 2), 1 To n)
  8.             For i = 1 To UBound(arr, 2)
  9.                 brr(i, n) = arr(k, i)
  10.             Next i
  11.         End If
  12.     Next k
  13.     Workbooks.Open ThisWorkbook.Path & "\文件2.xlsx"
  14.     Sheets("表222").Cells(Rows.Count, 1).End(3).Offset(1, 0).Resize(UBound(brr, 2), UBound(brr)) = Application.WorksheetFunction.Transpose(brr)
  15.     ActiveWorkbook.Close 0
  16. End Sub
复制代码
回复

使用道具 举报

发表于 2014-4-9 09:43 | 显示全部楼层
刚刚忘了说了,XLSX格式的文件有宏代码时需要另存为xlsm或xls格式,否则代码会丢失。
附件我重新传了个,解压后放在文件2.xlsx一块就行了。
回复

使用道具 举报

 楼主| 发表于 2014-4-9 09:43 | 显示全部楼层
hwc2ycy 发表于 2014-4-9 09:35
添加个按钮,指定宏。

1要同时满足这2个条件才能粘贴到《文件2的表222》
2粘贴到《文件2的表222》簿之前请清空
3不需要关闭《文件2的表222》
回复

使用道具 举报

发表于 2014-4-9 09:55 | 显示全部楼层    本楼为最佳答案   
zss7758258 发表于 2014-4-9 09:43
1要同时满足这2个条件才能粘贴到《文件2的表222》
2粘贴到《文件2的表222》簿之前请清空
3不需要关闭《 ...

以后注意最好把要求一次讲好。
  1. Sub test()
  2.     Dim rgh2, rgi2$
  3.     Dim arr
  4.     Dim i&
  5.     If Len(Range("h2").Value) = 0 Or Len(Range("i2").Value) = 0 Then Exit Sub
  6.     rgh2 = Range("h2")
  7.     rgi2 = "*" & Range("i2").Value & "*"
  8.     Dim wb As Workbook
  9.     Set wb = GetObject(ThisWorkbook.Path & "\文件2.xlsx")
  10.     arr = Range("a1").CurrentRegion.Value
  11.     Application.ScreenUpdating = False
  12.     With wb
  13.         With .Worksheets("表222")
  14.             .Rows("2:" & Rows.Count).Clear
  15.             For i = 2 To UBound(arr)
  16.                 If arr(i, 1) = rgh2 Then
  17.                     If arr(i, 3) Like rgi2 Then
  18.                         Cells(i, 1).Resize(, UBound(arr)).Copy .Cells(Rows.Count, 1).End(xlUp).Offset(1)
  19.                     End If
  20.                 End If
  21.             Next
  22.         End With
  23.         Windows(.Name).Visible = True
  24.     End With
  25.     Application.ScreenUpdating = True
  26.     MsgBox "处理完成"
  27. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2014-4-9 09:58 | 显示全部楼层
风林火山 发表于 2014-4-9 09:42

可以不关闭《文件2的表222》吗?
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 19:40 , Processed in 1.281215 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表