某表（2） 数据替换到 某表 能优化下代码吗

再回首-沉默

某表带（2）的数据替换到没带（2）的某表
①所有表的行数不一致 ②某表跟某表（2），列数会一致 【关于行列数不一致我是用选择A1单元格 按CTRL+A 就可以解决这个问题】

目前我弄的哪个代码行数太多了1000来行代码，因为有80多个表，可能就只有里面部分10个表，10个表其中几个带（2）要替换数据，这个能帮我优化下简洁的代码吗？我看内容都是大差不差的，差距就是表名不一致


Sub 数据替换()

    If testFile("柱 (2)") Then
        Sheets("柱").Activate
        Range("A1").CurrentRegion.Select
        Selection.Clear
        Sheets("柱 (2)").Activate
        Range("A1").CurrentRegion.Select
        Selection.Copy
        Sheets("柱").Activate
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False
    End If

    If testFile("自定义面 (2)") Then
        Sheets("自定义面").Activate
        Range("A1").CurrentRegion.Select
        Selection.Clear
        Sheets("自定义面 (2)").Activate
        Range("A1").CurrentRegion.Select
        Selection.Copy
        Sheets("自定义面").Activate
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False
    End If

    If testFile("自定义贴面 (2)") Then
        Sheets("自定义贴面").Activate
        Range("A1").CurrentRegion.Select
        Selection.Clear
        Sheets("自定义贴面 (2)").Activate
        Range("A1").CurrentRegion.Select
        Selection.Copy
        Sheets("自定义贴面").Activate
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False
    End If
End Sub

'判断文件是否存在
Public Function testFile(fn As String)
    Dim flg As Boolean
    flg = False
    For i = 1 To Sheets.Count
        If Sheets(i).Name = fn Then
            flg = True
            Exit For
        End If
    Next
    testFile = flg
End Function

再回首-沉默

不太好修改，就算了，勉强用了吧，后面有新表名在，再加上去得了

边缘码农

再回首-沉默 发表于 2024-7-1 11:59
不太好修改，就算了，勉强用了吧，后面有新表名在，再加上去得了

1. Sub 数据替换2()
   
2.    
   
3.     Dim I As Long
   
4.     Dim NewName As String
   
5.    
   
6.     For I = 1 To ThisWorkbook.Sheets.Count
   
7.         ' 按照工作簿中工作表的数量进行循环
   
8.         NewName = Sheets(I).Name
   
9.         If InStr(Sheets(I).Name, "(2)") > 0 Then
   
10.             ' 如果工作表名称中含有“（2）”
    
11.             NewName = Trim(Replace(Sheets(I).Name, "(2)", ""))
    
12.             If WorksheetExists(NewName) Then
    
13.                 ' 如果NewName这个工作表存在
    
14.                 Sheets(NewName).Activate
    
15.                 Range("A1").CurrentRegion.Select
    
16.                 Selection.Clear
    
17.                 Sheets(I).Activate
    
18.                 Range("A1").CurrentRegion.Select
    
19.                 Selection.Copy
    
20.                 Sheets(NewName).Activate
    
21.                 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False
    
22.                 Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False
    
23.             Else
    
24.                 MsgBox "工作簿中不存在名称为  " & NewName & "   的工作表，请检查。"
    
25.                 End
    
26.             End If
    
27.         End If
    
28.     Next
    
29.     MsgBox "OK!"
    
30. End Sub
    
31. Function WorksheetExists(sheetName As String, Optional wb As Workbook) As Boolean
    
32.     ' 测试工作表是否存在
    
33.     Dim sheet As Object
    
34.    
    
35.     If wb Is Nothing Then Set wb = ThisWorkbook
    
36.     On Error Resume Next
    
37.     Set sheet = wb.Sheets(sheetName)
    
38.     On Error GoTo 0
    
39.     WorksheetExists = Not sheet Is Nothing
    
40. End Function
    

复制代码

边缘码农

再回首-沉默

边缘码农 发表于 2024-7-1 12:32

大佬，我运行了你发的代码，但是总卡在这里，翻译了你发的代码，看不懂错哪了

边缘码农

再回首-沉默 发表于 2024-7-1 14:44
大佬，我运行了你发的代码，但是总卡在这里，翻译了你发的代码，看不懂错哪了

检查运行过程中 NewName  这个变量的值，看看和工作表的名称是否一致。检查一下工作表的名称中有没有空格。

再回首-沉默

边缘码农 发表于 2024-7-1 15:25
检查运行过程中 NewName  这个变量的值，看看和工作表的名称是否一致。检查一下工作表的名称中有没有空格 ...

大佬，工作表名称，前后中间有空白格的我都删除了，还是显示的那个，你那边能运行的吗

边缘码农

再回首-沉默 发表于 2024-7-1 15:38
大佬，工作表名称，前后中间有空白格的我都删除了，还是显示的那个，你那边能运行的吗

我这边运行正常。把你现在的附件传上来我看一下。

边缘码农

WorksheetExists这个函数使用了可选参数，可能是它的问题。在这个工程中中断一下，看看返回值是什么。如果一直返回False ，就会这样总是提示找不到。

边缘码农

我的环境和你的环境肯定是不一样的。