新人求助，麻烦帮忙缩减下对应的代码

yueyuexian5

不会vba的新人，由于是想把工作表-”活动优化文本配置初步(1).xlsm“中拥有和 “S-随机活动1.xls”“S-随机活动2.xls”一样的工作表，
复制黏贴为数值， 麻烦大佬看看对应的代码应该怎么处理。因为后续还要继续加工作表。所以想通过代码判断
”活动优化文本配置初步(1).xlsm“中是否有和其他几个要黏贴的表一致的工作表，如果有，就对应的黏贴过去。
因为后续可能还会有随机活动1，随机活动2......到随机活动n，工作表也会慢慢增加。每一次都要全部代码一个个加好麻烦。希望大佬帮帮忙

这是我现在用的自己录制后改的代码。

    Windows("工作表-活动优化文本配置初步(1).xlsm").Activate
    Sheets("活动a-a").Activate
    Cells.Select
    Cells.Copy
    Windows("S-随机活动1.xls").Activate
    Sheets("活动a-a").Activate
    Cells.Select
    Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False
    Windows("S-随机活动2.xls").Activate
    Sheets("活动a-a").Activate
    Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False

    Windows("工作表-活动优化文本配置初步(1).xlsm").Activate
    Sheets("活动b-b").Activate
    Cells.Select
    Cells.Copy
    Windows("S-随机活动1.xls").Activate
    Sheets("活动b-b").Activate
    Cells.Select
    Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False
    Windows("S-随机活动2.xls").Activate
    Sheets("活动b-b").Activate
    Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False

    Windows("工作表-活动优化文本配置初步(1).xlsm").Activate
    Sheets("用户a统计").Activate
    Cells.Select
    Cells.Copy
    Windows("S-随机活动1.xls").Activate
    Sheets("用户a统计").Activate
    Cells.Select
    Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False
    Windows("S-随机活动2.xls").Activate
    Sheets("用户a统计").Activate
    Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False
    .......以此类推，还有38行一样的代码。。。

yueyuexian5

希望大佬帮忙看后优化一下。因为小弟也是刚接触vba，只会录制，所以写的比较傻瓜。有没有大佬帮忙~

chaohuahch

你没有附件，不知道你想干嘛，而且优化好以后，也没有办法测试，是否能达到效果。

liulang0808

Windows("工作表-活动优化文本配置初步(1).xlsm").Activate
    Sheets("活动a-a").Activate
    Cells.Select
    Cells.Copy
    Windows("S-随机活动1.xls").Activate
    Sheets("活动a-a").Activate
    Cells.Select
    Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False


修改如下：
Windows("工作表-活动优化文本配置初步(1).xlsm").Sheets("活动a-a").cells.copy  Windows("S-随机活动1.xls").Sheets("活动a-a").[a1]
Windows("S-随机活动1.xls").Sheets("活动a-a").usedrange.value=Windows("S-随机活动1.xls").Sheets("活动a-a").usedrange.value

楼主的选择性粘贴数值，参考上面修改的吧

yueyuexian5

chaohuahch 发表于 2018-9-1 20:57
你没有附件，不知道你想干嘛，而且优化好以后，也没有办法测试，是否能达到效果。

大佬，附件我上传了，麻烦看看

yueyuexian5

liulang0808 发表于 2018-9-2 09:05
Windows("工作表-活动优化文本配置初步(1).xlsm").Activate
    Sheets("活动a-a").Activate
    Cells. ...

谢谢大佬，但是我的意思是，我现在有38行一模一样的代码，后续如果要加新的工作表，每加一个工作表，要加一行代码，很麻烦，希望可以让vba自动匹配，具体可以看看附件哈，大佬

liulang0808

yueyuexian5 发表于 2018-9-3 15:14
谢谢大佬，但是我的意思是，我现在有38行一模一样的代码，后续如果要加新的工作表，每加一个工作表，要加 ...

结合附件内容，再进一步举例说明下各个工作薄关系及处理需求吧

yueyuexian5

liulang0808 发表于 2018-9-3 19:08
结合附件内容，再进一步举例说明下各个工作薄关系及处理需求吧

好的，大佬。
具体需求是这样的。步骤如下
1、搜索“活动优化表”里面所有的工作表名称。 然后匹配随机活动表1和2的工作表名称。
2、当活动优化表和随机活动1.2 这三个工作簿中 有一样的工作表“a”的话
把活动优化工作簿的表"a"全选复制黏贴为数值到 随机活动表1和表2中的“表a”3、直到所有工作簿匹配完毕，即没有一样的工作表了，脚本结束。

ps：随机活动表的数量是可控的，如果我打开随机活动1.2.3.4.5张表 ，那就以此类推复制到这五张表。

不用考虑1.2表有这张表，3.4表没有这张表的情况。

liulang0808

1. Sub Macro1()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     For Each sh In Sheets
   
6.     d(sh.Name) = sh.Name
   
7.     Next sh
   
8.    
   
9. 
   
10.     With Workbooks.Open(ThisWorkbook.Path & "\S-随机活动1.xls")
    
11.         For Each sh In .Sheets
    
12.             If d.exists(sh.Name) Then
    
13.                 ThisWorkbook.Sheets(sh.Name).Cells.Copy sh.[a1]
    
14.                 sh.UsedRange.Value = sh.UsedRange.Value
    
15.             End If
    
16.         Next sh
    
17.     End With
    
18.    
    
19.     With Workbooks.Open(ThisWorkbook.Path & "\S-随机活动2.xls")
    
20.         For Each sh In .Sheets
    
21.             If d.exists(sh.Name) Then
    
22.                 ThisWorkbook.Sheets(sh.Name).Cells.Copy sh.[a1]
    
23.                 sh.UsedRange.Value = sh.UsedRange.Value
    
24.             End If
    
25.         Next sh
    
26.         
    
27.     End With
    
28.     Application.DisplayAlerts = True
    
29.     Application.ScreenUpdating = True
    
30.    
    
31. End Sub

复制代码

liulang0808

楼主看看是不是这个意思吧