gán công thức cho các o khi thỏa điều kiện (1 người xem)

[lmtuyen]

Dear Anh Chị!
Mình đã viết code VBA gán công thức trong Sheet" Output" ở các cột I & J, code chạy củng đúng yêu cầu của mình, nhưng thấy chập quá, mong Anh/Chị giúp cách tinh gọn để chạy nhanh hơn ạ.
Thanks!

 

[phucbugis]

Dear Anh Chị!
Mình đã viết code VBA gán công thức trong Sheet" Output" ở các cột I & J, code chạy củng đúng yêu cầu của mình, nhưng thấy chập quá, mong Anh/Chị giúp cách tinh gọn để chạy nhanh hơn ạ.
Thanks!

số liệu của bạn ít quá ---> ko biết là chậm hay nhanh.

bạn thử thêm đoạn dưới vào đầu và đuôi của code đó và chạy xem sao.

Application.ScreenUpdating = False

'Macro

Application.ScreenUpdating = True

' - - - -
bạn có thể sửa theo code lại như sau và test thử nhé

Private Sub CommandButton1_Click()
'vlookup cho sheet output
Dim k As Integer
Application.ScreenUpdating = False
    Range("I6:J1000").ClearContents
    
    For k = 6 To 19
        If Range("d" & k).Value <> "" Then
            Range("i" & k).Formula = "=vlookup(RC[-5],Schedule!R4C3:R1000C5,2,FALSE)"
            Range("j" & k).Formula = "=vlookup(RC[-6],Schedule!R4C3:R1000C5,3,FALSE)"
        'Else
            'Range("i" & k).Value = "" '[COLOR=#ff0000]ko can -> gop chung voi [/COLOR]Range("I6:J1000").ClearContents
            'Range("j" & k).Value = "" [COLOR=#ff0000]'ko can -> [/COLOR][COLOR=#FF0000]gop chung voi [/COLOR]Range("I6:J1000").ClearContents
        End If
    Next k
Application.ScreenUpdating = True
MsgBox " Finished"
End Sub

 

[lmtuyen]

Thanks bạn nhiều, click cái chạy ra liền hehe. khi chưa có 2 dòng này, ngồi vuốt râu nhìn nó ì ạch chạy.

 

[lmtuyen]

Bạn ơi kiểm tra giúp đoạn code này luôn nhé, Mình mới viết thêm và chạy lại bị chậm nửa hic.
Private Sub CommandButton1_Click()
'vlookup cho sheet output
Application.ScreenUpdating = False
Dim k As Integer, M As Integer
For k = 6 To 19
If Range("d" & k).Value <> "" Then
Range("i" & k).Formula = "=vlookup(RC[-5],Schedule!R4C3:R1000C5,2,FALSE)"
Range("j" & k).Formula = "=vlookup(RC[-6],Schedule!R4C3:R1000C5,3,FALSE)"


Else
Range("i" & k).Value = ""
Range("j" & k).Value = ""
End If
Next k
Application.ScreenUpdating = True
'copy to emtyrow
msg = " DO YOU WANT COPY DATA "
Style = vbOKCancel
Respone = MsgBox(msg, Style)
If Respone = vbOK Then
'xoa dong trong


Range("A6:J6").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
For M = 21 To 2000
If Trim(Worksheets("Output").Range("a" & M).Value) = "" Then
Range("a" & M).Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Exit For
End If
Next M
End If
Application.CutCopyMode = False


End Sub

 

[phucbugis]

cho hỏi,

- đoạn code dưới có phải bạn muốn chuyển toàn bộ số liệu của vùng từ A6:J6 trở xuống thành Value ko?
- do file bạn share ko có số liệu nên khi run đoạn đỏ đỏ đó -> nó quét xuống tận đáy.
- bạn up lại file đang chứa số liệu của sheet đó để mình test + có thể chỉnh lại code.

    If Respone = vbOK Then
        'xoa dong trong
        Range("A6:J6").Select
[COLOR=#ff0000]        Range(Selection, Selection.End(xlDown)).Select[/COLOR]
        Selection.Copy
        
        For M = 21 To 2000
            If Trim(Worksheets("Output").Range("a" & M).Value) = "" Then
                Range("a" & M).Activate
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
                
                Exit For
            End If
        Next M
    End If

 

[lmtuyen]

Bạn phucbugis ơi xem giúp file mình đính kèm nhé,
Thanks bạn nhiều.

 

[phucbugis]

Bạn phucbugis ơi xem giúp file mình đính kèm nhé,
Thanks bạn nhiều.

mình thấy code của bạn hoat động bình thường mà, có điều bạn test lại xem code mình mới cài có cho kết quả giống ko nhé
'- - - -
code cũ của bạn có đoạn:
Range(Selection, Selection.End(xlDown)).Select, nó sẽ xảy ra lỗi khi ô A19, A20 có chứa dữ liệu (đang liên kết với vùng bên dưới)
---> mình chuyển sang dùng Range([Output_footer].End(xlUp), [J6]).Select se~ an toàn hơn. (Output_footer là 1 Name)

Link: https://www.mediafire.com/?zgpuw27nnac2285

 

[lmtuyen]

Thanks Bạn nhiều, đơn giản và chạy rất nhanh, mình làm tiếp, có khó khăn gì mong Bạn giúp nhé

 

[lmtuyen]

Bạn phucbugis ơi giúp với, tình hình là mình đã viết xong file chạy củng đúng ý mình, thấy dung lượng khá nhẹ, chỉ khoảng 300k, nhưng đưa lên ổ mang của công ty dùng thì chạy không nổi, load về máy các nhân thì OK.

Xem giúp code của Sheet"Pending" giúp mình với nha.

 

[Let'GâuGâu]

Bạn phucbugis ơi giúp với, tình hình là mình đã viết xong file chạy củng đúng ý mình, thấy dung lượng khá nhẹ, chỉ khoảng 300k, nhưng đưa lên ổ mang của công ty dùng thì chạy không nổi, load về máy các nhân thì OK.

Xem giúp code của Sheet"Pending" giúp mình với nha.

tôi ko hiểu rỏ lắm là bạn đang làm gì, tôi chỉ viết lại code mà bạn viết thôi.
tinh thân là bạn ko nên select cell hay sheet nhiều quá việc này là cho màn hình nó cứ cà giựt, mà làm chậm tốc độ nữa
bạn thử test 2 đoạn code tôi viết lại từ code của bạn, xem nó có khá hơn ko

Sub DELTE_ROW_EMPTY()
'check dong trong cua sheet "scshedule"
    On Error GoTo thoat
    Range("C4:C" & Range("c1000").End(xlUp).Row).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
thoat: Exit Sub
    Range("B1").Select

End Sub
Sub copyschedule()
'copy data_schedule sang sheets pending

With Sheets("Pending")
    .Visible = True
    .Cells.EntireRow.Hidden = False
    .[A6:J6].Resize(.[a10000].End(3).Row).ClearContents
    .[a6].Resize(Sheet3.[C10000].End(3).Row, 5) = Sheet3.[c4].Resize(Sheet3.[C10000].End(3).Row, 5)
    .[h6].Resize(Sheet3.[j10000].End(3).Row, 8) = Sheet3.[j4].Resize(Sheet3.[J10000].End(3).Row, 8)
End With
  
End Sub

nếu ko được nữa thì cho nó vô cái mảng
=========
mà hình như là cũng ko cần bật chế độ visible= true ,nó cũng chép qua được, bạnt hử xem nha

 

[phucbugis]

Bạn phucbugis ơi giúp với, tình hình là mình đã viết xong file chạy củng đúng ý mình, thấy dung lượng khá nhẹ, chỉ khoảng 300k, nhưng đưa lên ổ mang của công ty dùng thì chạy không nổi, load về máy các nhân thì OK.

Xem giúp code của Sheet"Pending" giúp mình với nha.

bạn điền công thức theo kiểu For Next thì chậm là đúng rồi

code của sheet Pending bạn thử thay thế đoạn sau

Private Sub CommandButton1_Click()
'Update sheets "pending"
Application.ScreenUpdating = False
    With ActiveSheet.Cells(Rows.Count, "A").End(xlUp)
        iRow = .Row
        .Offset(-iRow + 6, 5).Resize(iRow - 5).Value = "=SUMIF(Output!R21C4:R1000C5,Pending!RC[-5],Output!R21C5:R1000C5)"
        .Offset(-iRow + 6, 6).Resize(iRow - 5).Value = "=RC[-1]-RC[-2]"
    End With
Application.ScreenUpdating = True

'Call HiddenRow
MsgBox " Update successfull"

End Sub

Link: https://www.mediafire.com/?m306n48dlrrdfr3

'- - -
to LetGauGau
hiện tại mình chơi FBird được 1xx