不知道代码是否还能有改善空间让速度提升

cmo9020

test.rar (514.72 KB, 下载次数: 4)

2023-3-11 09:50 上传

点击文件名下载附件

各位导师周末愉快，请导师帮忙看一下
不知道代码是否还能有改善空间让速度提升
A1单元格是指定文件夹档案位置

1个文件夹内会有放1个月份30天的工作簿

这个代码主要是收集文件夹里面档案后2码是"牛肉"、"羊肉"，
打开档案之后指定sheet1工作表数据
依档案后2码名称复制过来这里的"牛肉"和"羊肉"分开存放数据

排除按钮、图形，只复制字体颜色和列高
排除开启目标文件显示更新链接所有提示
排除另一个人开启时显示只读提示

不知道是不是代码还有空间让他速度在提升


Sub CopyDataFromShee()
Dim wb As Workbook
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim lastRow As Long
Dim destRow As Long
Dim file As Variant


Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False


For Each wsName In Array("牛肉", "羊肉")
Set wsDest = ThisWorkbook.Worksheets(wsName)
wsDest.Cells.ClearContents
Next

Dim filePath As String


Dim wsNames As Variant

filePath = ThisWorkbook.Worksheets("Sheet1").Range("A1").Value
wsNames = Array("牛肉", "羊肉")

For Each wsName In wsNames
file = Dir(filePath & "*??" & wsName & ".xlsx")
While (file <> "")
Set wb = Workbooks.Open(filePath & file, ReadOnly:=True, UpdateLinks:=False)
For Each wsSource In wb.Worksheets
If wsSource.Name = "Sheet1" Then
Set wsDest = ThisWorkbook.Worksheets(wsName)
lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
destRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row + 2
wsSource.Range("A1:Z" & lastRow).Copy
wsDest.Range("A" & destRow).PasteSpecial xlPasteValuesAndNumberFormats
wsDest.Range("A" & destRow).PasteSpecial xlPasteAllUsingSourceTheme
wsDest.Rows(destRow).EntireRow.AutoFit
End If
Next
wb.Close SaveChanges:=False
file = Dir()
Wend
Next
   

Dim img As Object
For Each ws In Array("牛肉", "羊肉")
For Each img In ThisWorkbook.Worksheets(ws).Shapes
If Not img Is Nothing And Not img.TopLeftCell Is Nothing Then
If img.TopLeftCell.Row >= 2 And img.TopLeftCell.Row <= 200 And _
img.TopLeftCell.Column >= 1 And img.TopLeftCell.Column <= 10 Then
img.Delete
End If
End If
Next
Next

    ThisWorkbook.UpdateLinks = xlUpdateLinksNever
    ThisWorkbook.LinkSources Type:=xlLinkTypeExcelLinks
    ThisWorkbook.LinkSources Type:=xlLinkTypeOLELinks

Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True


End Sub

opiona

https://club.excelhome.net/thread-1409141-1-1.html