Nhờ các bác giúp cải thiện tốc độ xử lý của macro tìm và xóa các ô có chứa công thức là link đến các sheet khác

tungstchn

Thành viên mới
Tham gia ngày
7 Tháng mười 2019
Bài viết
16
Được thích
3
Điểm
15
Tuổi
38
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
 

ppc0312

whom?
Tham gia ngày
2 Tháng tư 2008
Bài viết
464
Được thích
219
Điểm
710
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
Tranh thủ tết học lại , hay đọc cơ bản về VBA đi,
Tìm hiểu về Find, Find next, Range
Tìm hiểu về tăng tốc chút (tắt tạm thời các active màn hình) ...
sẽ giải quyết vấn đề
 

batman1

Thành viên gắn bó
Tham gia ngày
8 Tháng chín 2014
Bài viết
2,847
Được thích
4,215
Điểm
560
Bạn thử 2 code sau. Nhớ thông báo kết quả nhé.
1. Chỉ chuyển công thức link tới sheet khác thành giá trị.
Mã:
Sub xuat_file()
Dim k As Long, cellAddr As String, rng As Range, cell_ As Range, unionRng As Range
'    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
    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 k = 1 To ActiveWorkbook.Sheets.Count
        Set rng = Worksheets(k).UsedRange
        Set cell_ = rng.Find(What:="!", After:=rng(1), LookIn:=xlFormulas, LookAt:= _
            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
        If Not cell_ Is Nothing Then
            cellAddr = cell_.Address
            Do
                If unionRng Is Nothing Then
                    Set unionRng = cell_
                Else
                    Set unionRng = Union(unionRng, cell_)
                End If
                Set cell_ = rng.FindNext(cell_)
            Loop Until cell_.Address = cellAddr
            unionRng.Value = unionRng.Value
        End If
        Set unionRng = Nothing
    Next k
End Sub
2. Chuyển mọi công thức thành giá trị.
Mã:
Sub xuat_file()
Dim k As Long
'    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
    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 k = 1 To ActiveWorkbook.Sheets.Count
        Worksheets(k).UsedRange.Value = Worksheets(k).UsedRange.Value
    Next k
End Sub
 

HieuCD

Thành viên gạo cội
Tham gia ngày
14 Tháng chín 2010
Bài viết
6,270
Được thích
11,666
Điểm
1,560
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
Thử code
Mã:
Sub xuat_file()
Dim Rng As Range, sArr(), Res(), n&, i&, j&
'    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
    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 n = 1 To ActiveWorkbook.Sheets.Count
        Set Rng = Worksheets(n).UsedRange
        If Rng.Count = 1 Then Set Rng = Rng.Resize(2)
        sArr = Rng.Value
        Res = Rng.Formula
        For i = 1 To UBound(sArr)
            For j = 1 To UBound(sArr, 2)
                If InStr(1, Res(i, j), "!") Then Res(i, j) = sArr(i, j)
            Next j
        Next i
        Rng.Formula = Res
    Next n
    Set Rng = Nothing
End Sub
 

tungstchn

Thành viên mới
Tham gia ngày
7 Tháng mười 2019
Bài viết
16
Được thích
3
Điểm
15
Tuổi
38
Bạn thử 2 code sau. Nhớ thông báo kết quả nhé.
1. Chỉ chuyển công thức link tới sheet khác thành giá trị.
Mã:
Sub xuat_file()
Dim k As Long, cellAddr As String, rng As Range, cell_ As Range, unionRng As Range
'    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
    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 k = 1 To ActiveWorkbook.Sheets.Count
        Set rng = Worksheets(k).UsedRange
        Set cell_ = rng.Find(What:="!", After:=rng(1), LookIn:=xlFormulas, LookAt:= _
            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
        If Not cell_ Is Nothing Then
            cellAddr = cell_.Address
            Do
                If unionRng Is Nothing Then
                    Set unionRng = cell_
                Else
                    Set unionRng = Union(unionRng, cell_)
                End If
                Set cell_ = rng.FindNext(cell_)
            Loop Until cell_.Address = cellAddr
            unionRng.Value = unionRng.Value
        End If
        Set unionRng = Nothing
    Next k
End Sub
2. Chuyển mọi công thức thành giá trị.
Mã:
Sub xuat_file()
Dim k As Long
'    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
    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 k = 1 To ActiveWorkbook.Sheets.Count
        Worksheets(k).UsedRange.Value = Worksheets(k).UsedRange.Value
    Next k
End Sub
Trước tiên e rất cảm ơn bác đã bỏ thời gian giúp em!!!!!! code 1 của bác chạy nhanh nhưng file xuất ra có một số ô báo lỗi #N/A mà e chưa tìm ra đc lý do bác ạ. Code 2 chạy tốt ko lỗi j. Cảm ơn bác 1 lần nữa!!!
Bài đã được tự động gộp:

Thử code
Mã:
Sub xuat_file()
Dim Rng As Range, sArr(), Res(), n&, i&, j&
'    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
    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 n = 1 To ActiveWorkbook.Sheets.Count
        Set Rng = Worksheets(n).UsedRange
        If Rng.Count = 1 Then Set Rng = Rng.Resize(2)
        sArr = Rng.Value
        Res = Rng.Formula
        For i = 1 To UBound(sArr)
            For j = 1 To UBound(sArr, 2)
                If InStr(1, Res(i, j), "!") Then Res(i, j) = sArr(i, j)
            Next j
        Next i
        Rng.Formula = Res
    Next n
    Set Rng = Nothing
End Sub
Code này của bác chạy quá ngon. Cảm ơn bác rất nhiều ạ!!!!!
 

tungstchn

Thành viên mới
Tham gia ngày
7 Tháng mười 2019
Bài viết
16
Được thích
3
Điểm
15
Tuổi
38
Tranh thủ tết học lại , hay đọc cơ bản về VBA đi,
Tìm hiểu về Find, Find next, Range
Tìm hiểu về tăng tốc chút (tắt tạm thời các active màn hình) ...
sẽ giải quyết vấn đề
Mình ko phải là dân chuyên về CNTT, công việc hiện tại cũng ko yêu cầu phải có kiến thức về lập trình nên đã học đi đc chữ nào đâu mà học lại :)). Chẳng qua muốn tăng hiệu quả, năng suất công việc nên tự mày mò vậy thôi. Cũng muốn học cơ bản (vì mình cũng thích lĩnh vực CNTT) nhưng ko có nhiều thời gian để theo đuổi sở thích vì vậy chỉ tự mày mò rồi lên đây nhờ sự giúp đỡ của các a/c và các bạn trên này để học đc cái j thì tốt cái đó thôi. Dù sao cũng cảm ơn bạn đã cho ý kiến!!
 

ppc0312

whom?
Tham gia ngày
2 Tháng tư 2008
Bài viết
464
Được thích
219
Điểm
710
Mình ko phải là dân chuyên về CNTT, công việc hiện tại cũng ko yêu cầu phải có kiến thức về lập trình nên đã học đi đc chữ nào đâu mà học lại :)). Chẳng qua muốn tăng hiệu quả, năng suất công việc nên tự mày mò vậy thôi. Cũng muốn học cơ bản (vì mình cũng thích lĩnh vực CNTT) nhưng ko có nhiều thời gian để theo đuổi sở thích vì vậy chỉ tự mày mò rồi lên đây nhờ sự giúp đỡ của các a/c và các bạn trên này để học đc cái j thì tốt cái đó thôi. Dù sao cũng cảm ơn bạn đã cho ý kiến!!
Vậy chờ hàng có sẵn vậy
Ở đây có nhiều người vậy, yên tâm, không lo
 

VetMini

Gian hùng bàn phiếm (thành viên trôi nước)
Tham gia ngày
21 Tháng mười hai 2012
Bài viết
7,917
Được thích
9,261
Điểm
560
Vậy chờ hàng có sẵn vậy
Ở đây có nhiều người vậy, yên tâm, không lo
Đâu có ai chịu khó tìm hàng có sẵn đâu mà bảo chờ.
Nếu nói đúng thì là chờ "hàng dâng tận miệng".
Ở đây nhiều người sẵn sàng, có 1 đơn hàng là có vài món dâng lên. Muốn mới có mới, muốn cũ có cũ (nhưng thường thì đồ cũ phải đánh bóng lại mới chịu xài).
 

HieuCD

Thành viên gạo cội
Tham gia ngày
14 Tháng chín 2010
Bài viết
6,270
Được thích
11,666
Điểm
1,560
Trước tiên e rất cảm ơn bác đã bỏ thời gian giúp em!!!!!! code 1 của bác chạy nhanh nhưng file xuất ra có một số ô báo lỗi #N/A mà e chưa tìm ra đc lý do bác ạ. Code 2 chạy tốt ko lỗi j. Cảm ơn bác 1 lần nữa!!!
Bài đã được tự động gộp:


Code này của bác chạy quá ngon. Cảm ơn bác rất nhiều ạ!!!!!
Thêm điều kiện công thức liên kết các ô cùng sheet
Mã:
Sub xuat_file()
Dim Rng As Range, sArr(), Res(), n&, i&, j&, shname$
'    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
    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 n = 1 To ActiveWorkbook.Sheets.Count
        shname = Worksheets(n).Name & "!"
        Set Rng = Worksheets(n).UsedRange
        If Rng.Count = 1 Then Set Rng = Rng.Resize(2)
        sArr = Rng.Value
        Res = Rng.Formula
        For i = 1 To UBound(sArr)
            For j = 1 To UBound(sArr, 2)
                If InStr(1, Res(i, j), "!") Then
                    If InStr(1, Res(i, j), shname) Then
                        Res(i, j) = Replace(Res(i, j), shname, "")
                    Else
                        Res(i, j) = sArr(i, j)
                    End If
                End If
            Next j
        Next i
        Rng.Formula = Res
    Next n
    Set Rng = Nothing
End Sub
 

HeSanbi

Thành viên tích cực
Tham gia ngày
24 Tháng hai 2013
Bài viết
1,196
Được thích
1,093
Điểm
560
Bạn thử sử dụng Thủ tục dưới đây.

Ưu điểm:
1. Không lặp qua toàn bộ mảng gây tốn kém.
2. Chuyển thành giá trị Nếu Sheet hiện hành có trong tham chiếu cùng với một Sheet khác. Hoặc tham chiếu khác sổ làm việc.
3. Hoạt động tốt với sổ làm việc có tên ngoại lệ.
--------------------

JavaScript:
'Chuyen Doi Tham Chieu Khac Trang Tinh Hien Tai Thanh Gia Tri
Sub RefOutsideToValue()
  With ActiveWorkbook
    Dim Path As String
    Path = .Path & "\" & VBA.Replace(.Name, ".xls", VBA.Format(VBA.Now, "_d.m.yyyy") & ".xls", , ,1)
    .SaveCopyAs Path
    Application.Workbooks.Open Path
    '---------------------------------'
    Dim Rng As Range, Ref As Range, sht As Worksheet, sht2 As Worksheet
    Dim Arr As Variant
    On Error Resume Next
    Dim LastUP As Boolean
    LastUP = Application.ScreenUpdating
    Application.ScreenUpdating = False
    '---------------------------------'
    For Each sht In ActiveWorkbook.Worksheets
      Set Rng = sht.UsedRange
      Arr = Rng.Formula
      For Each Ref In Rng.SpecialCells(xlCellTypeFormulas).Find("*!")
        For Each sht2 In ActiveWorkbook.Worksheets
          If Ref.Formula Like "*[*]*!*" Or _
          (Not sht2 Is sht And Ref.Formula Like "*" & sht2.Name & "*!*") Then
            Arr(Ref.Row - Rng.Row + 1, Ref.Column - Rng.Column + 1) = Ref.Value2
            Exit For
          End If
        Next sht2
      Next
      Rng.Formula = Arr
    Next sht
    '---------------------------------'
  End With
  Application.ScreenUpdating = LastUP
  On Error GoTo 0
  Set Rng = Nothing: Set Ref = Nothing: Set sht = Nothing
End Sub
 
Lần chỉnh sửa cuối:

tungstchn

Thành viên mới
Tham gia ngày
7 Tháng mười 2019
Bài viết
16
Được thích
3
Điểm
15
Tuổi
38
Bạn thử sử dụng Thủ tục dưới đây.

Ưu điểm:
1. Không lặp qua toàn bộ mảng gây tốn kém.
2. Chuyển thành giá trị Nếu Sheet hiện hành có trong tham chiếu cùng với một Sheet khác. Hoặc tham chiếu khác sổ làm việc.
3. Hoạt động tốt với sổ làm việc có tên ngoại lệ.
--------------------

JavaScript:
'Chuyen Doi Tham Chieu Khac Trang Tinh Hien Tai Thanh Gia Tri
Sub RefOutsideToValue()
  With ActiveWorkbook
    Dim Path As String
    Path = .Path & "\" & VBA.Replace(.Name, ".xls", VBA.Format(VBA.Now, "_d.m.yyyy") & ".xls", , ,1)
    .SaveCopyAs Path
    Application.Workbooks.Open Path
    '---------------------------------'
    Dim Rng As Range, Ref As Range, sht As Worksheet, sht2 As Worksheet
    Dim Arr As Variant
    On Error Resume Next
    Dim LastUP As Boolean
    LastUP = Application.ScreenUpdating
    Application.ScreenUpdating = False
    '---------------------------------'
    For Each sht In ActiveWorkbook.Worksheets
      Set Rng = sht.UsedRange
      Arr = Rng.Formula
      For Each Ref In Rng.SpecialCells(xlCellTypeFormulas).Find("*!")
        For Each sht2 In ActiveWorkbook.Worksheets
          If Ref.Formula Like "*[*]*!*" Or _
          (Not sht2 Is sht And Ref.Formula Like "*" & sht2 & "*!*") Then
            Arr(Ref.Row - Rng.Row + 1, Ref.Column - Rng.Column + 1) = Ref.Value2
            Exit For
          End If
        Next sht2
      Next
      Rng.Formula = Arr
    Next sht
    '---------------------------------'
  End With
  Application.ScreenUpdating = LastUP
  On Error GoTo 0
  Set Rng = Nothing: Set Ref = Nothing: Set sht = Nothing
End Sub
Ko biết sao nhưng code này của bác chỉ thay đc 1 ô thôi bác ạ
 

HeSanbi

Thành viên tích cực
Tham gia ngày
24 Tháng hai 2013
Bài viết
1,196
Được thích
1,093
Điểm
560
Kết quả đây bác ơi. chỉ chuyển ddc 1 ô trên cùng bên phải của mảng bác ạ
-----------

Code trên đúng là Gặp lỗi

Bạn có thể sử dụng code dưới đây

JavaScript:
'Chuyen Doi Tham Chieu Khac Trang Tinh Hien Tai Thanh Gia Tri
Sub RefOutsideToValue()
  With ActiveWorkbook
    Dim Path As String
    If .Path = "" Then Exit Sub
    Path = .Path "\" & VBA.Replace(.Name, ".xls", VBA.Format(VBA.Now, "_d.m.yyyy") & ".xls", , , 1)
    .SaveCopyAs Path
    Application.Workbooks.Open Path
    '---------------------------------'
    Dim Rng As Range, Rngs As Range, Ref As Range, first$
    Dim sht As Worksheet, sht2 As Worksheet
    Dim Arr As Variant
    On Error Resume Next
    Dim LastUP As Boolean
    LastUP = Application.ScreenUpdating
    Application.ScreenUpdating = False
    '---------------------------------'
    For Each sht In ActiveWorkbook.Worksheets
      Set Rngs = sht.UsedRange
      Arr = Rngs.Formula
      Set Rng = Rngs.SpecialCells(xlCellTypeFormulas)
      Set Ref = Rng.Find("*!*", LookIn:=xlFormulas)
      If Not Ref Is Nothing Then
        first = Ref.Address
        Do
          For Each sht2 In ActiveWorkbook.Worksheets
            If Ref.Formula Like "*[[]*[]]*!*" Or _
            (Not sht2 Is sht And Ref.Formula Like "*" & sht2.Name & "*!*") Then
              Arr(Ref.Row - Rngs.Row + 1, Ref.Column - Rngs.Column + 1) = Ref.Value2
              Exit For
            End If
          Next sht2
          Set Ref = Rng.FindNext(Ref)
        Loop While Not Ref Is Nothing And Ref.Address <> first
      End If
      Rngs.Formula = Arr
    Next sht
    '---------------------------------'
  End With
  Application.ScreenUpdating = LastUP
  On Error GoTo 0
  Set Rng = Nothing: Set Rngs = Nothing: Set Ref = Nothing: Set sht = Nothing
End Sub
 

tungstchn

Thành viên mới
Tham gia ngày
7 Tháng mười 2019
Bài viết
16
Được thích
3
Điểm
15
Tuổi
38
-----------

Code trên đúng là Gặp lỗi

Bạn có thể sử dụng code dưới đây

JavaScript:
'Chuyen Doi Tham Chieu Khac Trang Tinh Hien Tai Thanh Gia Tri
Sub RefOutsideToValue()
  With ActiveWorkbook
    Dim Path As String
    If .Path = "" Then Exit Sub
    Path = .Path "\" & VBA.Replace(.Name, ".xls", VBA.Format(VBA.Now, "_d.m.yyyy") & ".xls", , , 1)
    .SaveCopyAs Path
    Application.Workbooks.Open Path
    '---------------------------------'
    Dim Rng As Range, Rngs As Range, Ref As Range, first$
    Dim sht As Worksheet, sht2 As Worksheet
    Dim Arr As Variant
    On Error Resume Next
    Dim LastUP As Boolean
    LastUP = Application.ScreenUpdating
    Application.ScreenUpdating = False
    '---------------------------------'
    For Each sht In ActiveWorkbook.Worksheets
      Set Rngs = sht.UsedRange
      Arr = Rngs.Formula
      Set Rng = Rngs.SpecialCells(xlCellTypeFormulas)
      Set Ref = Rng.Find("*!*", LookIn:=xlFormulas)
      If Not Ref Is Nothing Then
        first = Ref.Address
        Do
          For Each sht2 In ActiveWorkbook.Worksheets
            If Ref.Formula Like "*[[]*[]]*!*" Or _
            (Not sht2 Is sht And Ref.Formula Like "*" & sht2.Name & "*!*") Then
              Arr(Ref.Row - Rngs.Row + 1, Ref.Column - Rngs.Column + 1) = Ref.Value2
              Exit For
            End If
          Next sht2
          Set Ref = Rng.FindNext(Ref)
        Loop While Not Ref Is Nothing And Ref.Address <> first
      End If
      Rngs.Formula = Arr
    Next sht
    '---------------------------------'
  End With
  Application.ScreenUpdating = LastUP
  On Error GoTo 0
  Set Rng = Nothing: Set Rngs = Nothing: Set Ref = Nothing: Set sht = Nothing
End Sub
báo lỗi ngay ở đoạn này bác ơi =>
Path = .Path "\" & VBA.Replace(.Name, ".xls", VBA.Format(VBA.Now, "_d.m.yyyy") & ".xls", , , 1)
 
Top Bottom