Tối ưu hóa đoạn vba

[maiban1986]

chào anh chị. em đang dùng đoạn vba dưới, mỗi lần sử dụng dẫn đến file chạy rất chậm. nhờ anh chị có cách nào tối ưu đoạn vba dưới không. em xin cảm ơn
Sub GhepTextMulVung(Data, Vung As Range)
Dim avKQ()
Dim lngIndex As Long
Dim v
Dim lngNum As Long
Dim rngVung As Range, lngRowKQ As Long, lngRowData As Long, lngRowDataMax As Long
lngRowData = LBound(Data, 1) - 1
lngRowDataMax = UBound(Data)

For Each rngVung In Vung.Areas
If rngVung.Rows.Count = 1 Then
ReDim avKQ(1 To 1, 1 To 1)
Else
ReDim avKQ(1 To rngVung.Rows.Count, 1 To 1)
End If
For lngRowKQ = 1 To UBound(avKQ)
lngRowData = lngRowData + 1
If lngRowData > lngRowDataMax Then
Exit For
Else
avKQ(lngRowKQ, 1) = Data(lngRowData, 1)
End If

Next
rngVung.Value = avKQ

Next rngVung

End Sub

 

[batman1]

Trong code bài 1, mảng avKQ là 2 chiều 1 cột vì vậy nên cho là Data cũng là 2 chiều 1 cột.
Có lẽ không có file giả định thì đoán thôi bác.

Tôi nói về cái khác. Hãy nhập A1:A11 = 1, 2, ..., 11, sau đó chạy sub test, sau đó xóa kết quả B: D, rồi chạy sub test1. Kết quả chạy test và test1 khác nhau một trời một vực. Nhìn code cũng thấy lôgíc khác mà.

Sub GhepTextMulVung(Data, Vung As Range)
Dim avKQ()
Dim lngIndex As Long
Dim v
Dim lngNum As Long
Dim rngVung As Range, lngRowKQ As Long, lngRowData As Long, lngRowDataMax As Long
    lngRowData = LBound(Data, 1) - 1
    lngRowDataMax = UBound(Data)
   
    For Each rngVung In Vung.Areas
        If rngVung.Rows.Count = 1 Then
            ReDim avKQ(1 To 1, 1 To 1)
        Else
            ReDim avKQ(1 To rngVung.Rows.Count, 1 To 1)
        End If
        For lngRowKQ = 1 To UBound(avKQ)
            lngRowData = lngRowData + 1
            If lngRowData > lngRowDataMax Then
                Exit For
            Else
                avKQ(lngRowKQ, 1) = Data(lngRowData, 1)
            End If
        Next
        rngVung.Value = avKQ
    Next rngVung
End Sub

Sub GhepTextMulVung1(Data, Vung As Range)
Dim rngVung As Range
For Each rngVung In Vung.Areas
    rngVung.Value = Data
Next rngVung
End Sub

Sub test()
Dim Data(), Vung As Range
    Data = Sheet1.Range("A1:A11").Value
    Set Vung = Sheet1.Range("B1:B5,C1:C2,D1:D3")
    GhepTextMulVung Data, Vung
End Sub

Sub test1()
Dim Data(), Vung As Range
    Data = Sheet1.Range("A1:A11").Value
    Set Vung = Sheet1.Range("B1:B5,C1:C2,D1:D3")
    GhepTextMulVung1 Data, Vung
End Sub

 

[CHAOQUAY]

Tôi nói về cái khác. Hãy nhập A1:A11 = 1, 2, ..., 11, sau đó chạy sub test, sau đó xóa kết quả B: D, rồi chạy sub test1. Kết quả chạy test và test1 khác nhau một trời một vực. Nhìn code cũng thấy lôgíc khác mà.

Sub GhepTextMulVung(Data, Vung As Range)
Dim avKQ()
Dim lngIndex As Long
Dim v
Dim lngNum As Long
Dim rngVung As Range, lngRowKQ As Long, lngRowData As Long, lngRowDataMax As Long
    lngRowData = LBound(Data, 1) - 1
    lngRowDataMax = UBound(Data)
  
    For Each rngVung In Vung.Areas
        If rngVung.Rows.Count = 1 Then
            ReDim avKQ(1 To 1, 1 To 1)
        Else
            ReDim avKQ(1 To rngVung.Rows.Count, 1 To 1)
        End If
        For lngRowKQ = 1 To UBound(avKQ)
            lngRowData = lngRowData + 1
            If lngRowData > lngRowDataMax Then
                Exit For
            Else
                avKQ(lngRowKQ, 1) = Data(lngRowData, 1)
            End If
        Next
        rngVung.Value = avKQ
    Next rngVung
End Sub

Sub GhepTextMulVung1(Data, Vung As Range)
Dim rngVung As Range
For Each rngVung In Vung.Areas
    rngVung.Value = Data
Next rngVung
End Sub

Sub test()
Dim Data(), Vung As Range
    Data = Sheet1.Range("A1:A11").Value
    Set Vung = Sheet1.Range("B1:B5,C1:C2,D1:D3")
    GhepTextMulVung Data, Vung
End Sub

Sub test1()
Dim Data(), Vung As Range
    Data = Sheet1.Range("A1:A11").Value
    Set Vung = Sheet1.Range("B1:B5,C1:C2,D1:D3")
    GhepTextMulVung1 Data, Vung
End Sub

Hóa ra ý tưởng lại là như vậy.