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

边缘码农

再回首-沉默 发表于 2024-7-1 16:32
嗯嗯呢，看来我还是有待提高表达能力，哈哈哈

打开   vba代码汇总表 (2)  这个文件，在这个文件中运行 ...

正在审核的代码是  数据辅复制3，不知道为什么这么长时间。



你自己修改一下 吧。

边缘码农

那个代码审核通过了，在11楼，你试试看。

再回首-沉默

边缘码农 发表于 2024-7-1 16:04
Sub 数据替换3()
   
    Dim I As Long, J As Long

大佬试了下，还是不太行，好像少了循环运行，他只运行了一次工作表的替换，后面的工作表就不动了

打开   vba代码汇总表 (2)  这个文件，在这个文件中运行这个文件中的代码，一切正常。
打开   表3 这个文件，在这个文件中运行vba代码汇总表 (2)  这个文件的代码，只运行一次替换，后续的表不会替换

边缘码农

再回首-沉默 发表于 2024-7-1 16:54
大佬试了下，还是不太行，好像少了循环运行，他只运行了一次工作表的替换，后面的工作表就不动了

打开 ...

是这一句： For I = 1 To ThisWorkbook.Sheets.Count  ，取的是  vba代码汇总表 (2)  这个工作表的工作表数量。我再想想，以前从未处理过这样的代码运行方式。

边缘码农

再回首-沉默 发表于 2024-7-1 16:54
大佬试了下，还是不太行，好像少了循环运行，他只运行了一次工作表的替换，后面的工作表就不动了

打开 ...

Sub 数据替换3()
   
    Dim I As Long, J As Long
    Dim NewName As String
    Dim Cz As String
    Dim wb As Workbook
    Dim nowWbName As String
    For Each wb In Application.Workbooks
        '在当前打开的工作簿中循环
        If wb.Name <> ThisWorkbook.Name Then
            '删除工作表名称中的空格
            For I = 1 To wb.Sheets.Count
                ' 按照工作簿中工作表的数量进行循环
                wb.Sheets(I).Name = Trim(Replace(wb.Sheets(I).Name, " ", ""))
                kk = wb.Sheets(I).Name
            Next
            For I = 1 To wb.Sheets.Count
                ' 按照工作簿中工作表的数量进行循环
                Cz = "否"
                If InStr(wb.Sheets(I).Name, "(2)") > 0 Then
                    ' 如果工作表名称中含有“（2）”
                    NewName = Trim(Replace(wb.Sheets(I).Name, "(2)", ""))
                    For J = 1 To wb.Sheets.Count
                        If wb.Sheets(J).Name = NewName Then
                            ' 如果NewName这个工作表存在
                            wb.Sheets(NewName).Activate
                            Range("A1").CurrentRegion.Select
                            Selection.Clear
                            wb.Sheets(I).Activate
                            Range("A1").CurrentRegion.Select
                            Selection.Copy
                            wb.Sheets(NewName).Activate
                            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False
                            Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False
                            Cz = "是"
                        End If
                    Next
                    If Cz <> "是" Then
                        MsgBox "工作簿中不存在名称为  " & NewName & "   的工作表，请检查。"
                        End
                    End If
                End If
            Next
        End If
    Next wb
    MsgBox "OK!"
End Sub

边缘码农

发了个新代码，审核中。

新代码会对所有打开的工作簿进行操作，所以，在使用的时候要将其他的工作簿关闭，以防止出现误操作。