tungstchn
Thành viên mới
- Tham gia
- 7/10/19
- Bài viết
- 18
- Được thích
- 3
Tình hình là e có 1 file có nhiều ô chứa công thức là link với dự liệu ở sheet khác. e muốn tạo cmd buttom để khi cần xuất dữ liệu từ file đó ra 1 file mới và các ô chứa công thức có link với các sheet khác sẽ bị thay thế bằng dữ liệu của chính ô đó (ko còn link với các sheet hay các book khác nữa). e đã mò ra đoạn code ở dưới. Ở quy mô thử nghiệm thì code đã chay đúng như mong muốn. Nhưng khi đưa vào chạy với 1 file (.xls) có dung lượng độ 3mb thì nó chạy chậm quá (mất cả 15' chưa chạy xong). Các bác có cách nào để cải thiện tốc độ chạy thì chỉ giúp e với ạ. E cảm ơn.
Sub xuat_file()
'Copy wbook dang lam viec
MsgBox ("Luu y: File moi se luu de len file cu.")
ActiveWorkbook.SaveCopyAs ActiveWorkbook.Path & "\" & Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".") - 1) & "_" & Day(Date) & "." & Month(Date) & "." & Year(Date) & "." & Mid(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".") + 1, InStrRev(ActiveWorkbook.Name, ".") + 1)
'Thay the du lieu cua cac o co link du lieu voi wbook hoac wsheet khac bang du lieu cu chinh no
Dim i As Integer
Application.Workbooks.Open (ActiveWorkbook.Path & "\" & Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".") - 1) & "_" & Day(Date) & "." & Month(Date) & "." & Year(Date) & "." & Mid(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".") + 1, InStrRev(ActiveWorkbook.Name, ".") + 1))
For i = 1 To ActiveWorkbook.Sheets.Count
Worksheets(i).Activate
Do Until Cells.Find(What:="!", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False) Is Nothing
Cells.Find(What:="!", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Loop
Next i
End Sub
Sub xuat_file()
'Copy wbook dang lam viec
MsgBox ("Luu y: File moi se luu de len file cu.")
ActiveWorkbook.SaveCopyAs ActiveWorkbook.Path & "\" & Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".") - 1) & "_" & Day(Date) & "." & Month(Date) & "." & Year(Date) & "." & Mid(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".") + 1, InStrRev(ActiveWorkbook.Name, ".") + 1)
'Thay the du lieu cua cac o co link du lieu voi wbook hoac wsheet khac bang du lieu cu chinh no
Dim i As Integer
Application.Workbooks.Open (ActiveWorkbook.Path & "\" & Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".") - 1) & "_" & Day(Date) & "." & Month(Date) & "." & Year(Date) & "." & Mid(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".") + 1, InStrRev(ActiveWorkbook.Name, ".") + 1))
For i = 1 To ActiveWorkbook.Sheets.Count
Worksheets(i).Activate
Do Until Cells.Find(What:="!", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False) Is Nothing
Cells.Find(What:="!", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Loop
Next i
End Sub