Chuyễn code bình thường sang mảng để tăng tốc độ

Haffaz Aladeen · 10/9/21

Xin chào cả nhà ạ!

Em đang làm 1 file kiểu gần giống như nhập liệu, nhưng em dùng find method thì tốc độ chưa như em mong muốn.
Nên em nhờ mọi người chuyển qua sử dụng mảng giúp em với ạ. File em gửi đính kèm.
Vì em đã chỉnh sửa file rồi nên hơi khó hiểu ạ. Yêu cầu là nhập vào các ô tô màu xanh, chạy code ở module 1, sẽ tìm tương ứng theo ô C1 trong bảng dữ liệu ở cùng sheet DATA-PACK cột "2", chuyển dữ liệu tương ứng trong bảng vào trong các ô đã nhập (tô màu xanh) vào sheet ok. (hiện tại code em như thế). Nhờ các anh chị chuyển giúp em sang mảng ạ.

Với thêm 1 nhờ vã nhỏ là em muốn sau khi nạp dữ liệu vào rồi, thì xóa tất cả những dòng ở sheet ok nếu dữ liệu ở cột "2" không có trong cột "2" bên sheet DATA-PACK. tất nhiên cũng theo mảng luôn ạ

Em cảm ơn ạ!

SA_DQ · 10/9/21

Bạn đang thiếu chú thích cho 4 các ô màu xanh & như vậy không biết bạn sẽ nhập gì vô chúng?
Thứ 2: Bạn dấu macro thân thương của bạn đi rồi & như vậy là khiếm nhã với người có ý giúp bạn.
Thứ 3: Đồng ý là chỉ cần đưa file giả lập lên DĐ, nhưng file giả lập hiện đang rất tồi!

Haffaz Aladeen · 10/9/21

SA_DQ đã viết:
Bạn đang thiếu chú thích cho 4 các ô màu xanh & như vậy không biết bạn sẽ nhập gì vô chúng?
Thứ 2: Bạn dấu macro thân thương của bạn đi rồi & như vậy là khiếm nhã với người có ý giúp bạn.
Thứ 3: Đồng ý là chỉ cần đưa file giả lập lên DĐ, nhưng file giả lập hiện đang rất tồi!

Hic, em xin lỗi nhiều ạ. :oops:

Em quên mất vụ macro í ạ, chứ không phải cố ý đâu.
4 ô màu xanh nhập dữ liệu dạng text bất kỳ ạ, không giới hạn gì cả.
File em hơi ngáo, nhờ mọi người thông cảm. :wallbash:

SA_DQ · 10/9/21

PHP:

   With Rng.Find(Sheet1.Range("C1"), LookIn:=xlValues, lookat:=xlWhole)
        Sheets("OK").Range("C" & n3 + 1) = .Offset(, 1).Value
        Sheets("OK").Range("B" & n3 + 1) = Sheet1.Range("C1").Value
        Sheets("OK").Range("D" & n3 + 1) = .Offset(, 2).Value
        Sheets("OK").Range("E" & n3 + 1) = Sheet1.Range("D2")
        Sheets("OK").Range("F" & n3 + 1) = Sheet1.Range("D3")
        Sheets("OK").Range("G" & n3 + 1) = Now()
        Sheets("OK").Range("H" & n3 + 1) = Sheet1.Range("C4")
    End With

Nếu bạn nào đó nhập vô [C1] thứ trời ơi thì đỗ bễ cả hệ thống là khó tránh khỏi, đề nghị bạn tường minh hơn, ví dụ:

Dim Rng as range, sRng as range

Set Rng = Sheet1.Range("B6", "B15006")
Set sRng= Rng.Find(Sheet1.Range("C1"), LookIn:=xlValues, lookat:=xlWhole)
If sRng Is Nothing Then

else

End If

Maika8008 · 10/9/21

Haffaz Aladeen đã viết:
Xin chào cả nhà ạ!

Em đang làm 1 file kiểu gần giống như nhập liệu, nhưng em dùng find method thì tốc độ chưa như em mong muốn.
Nên em nhờ mọi người chuyển qua sử dụng mảng giúp em với ạ. File em gửi đính kèm.
Vì em đã chỉnh sửa file rồi nên hơi khó hiểu ạ. Yêu cầu là nhập vào các ô tô màu xanh, chạy code ở module 1, sẽ tìm tương ứng theo ô C1 trong bảng dữ liệu ở cùng sheet DATA-PACK cột "2", chuyển dữ liệu tương ứng trong bảng vào trong các ô đã nhập (tô màu xanh) vào sheet ok. (hiện tại code em như thế). Nhờ các anh chị chuyển giúp em sang mảng ạ.

Với thêm 1 nhờ vã nhỏ là em muốn sau khi nạp dữ liệu vào rồi, thì xóa tất cả những dòng ở sheet ok nếu dữ liệu ở cột "2" không có trong cột "2" bên sheet DATA-PACK. tất nhiên cũng theo mảng luôn ạ

Em cảm ơn ạ!

Thử file. Còn cái nhờ vả nhỏ kia lại chẳng nhỏ chút nào so với cái chính => để sau.

VetMini · 10/9/21

Maika8008 đã viết:
Thử file. Còn cái nhờ vả nhỏ kia lại chẳng nhỏ chút nào so với cái chính => để sau.

Trừ cách làm bảng băm, hay sort mảng để dùng phương pháp dò nhị phân. Bạn làm cách nào để dò mảng nhanh hơn phương thức Find vậy?

Maika8008 · 10/9/21

VetMini đã viết:
Trừ cách làm bảng băm, hay sort mảng để dùng phương pháp dò nhị phân. Bạn làm cách nào để dò mảng nhanh hơn phương thức Find vậy?

Tôi thử với dữ liệu vài chục ngàn dòng rồi. Dò mảng nhanh hơn mà.

VetMini · 10/9/21

Maika8008 đã viết:
Tôi thử với dữ liệu vài chục ngàn dòng rồi. Dò mảng nhanh hơn mà.

Cái code tôi nhìn ở bài #4 nó tính cả đống Ranges. Một lần Sheets(tên sheet) là phải tính sheet, một lần Range("A"&...) là phải tính range.
Tôi khong mở file xls nên không biết code thực là gì.

Maika8008 · 10/9/21

VetMini đã viết:
Cái code tôi nhìn ở bài #4 nó tính cả đống Ranges. Một lần Sheets(tên sheet) là phải tính sheet, một lần Range("A"&...) là phải tính range.
Tôi khong mở file xls nên không biết code thực là gì.

Ở sheet1 lấy 3 cột trong bảng, 1 Now và 3 ô của sheet1 (D2, D3 và C4) chép qua dòng trống đầu tiên sheet 3, tương tự như bài #4 thôi bác.

Haffaz Aladeen · 10/9/21

Maika8008 đã viết:
Thử file. Còn cái nhờ vả nhỏ kia lại chẳng nhỏ chút nào so với cái chính => để sau

Tuyệt vời! em cảm ơn anh nhiều.

Maika8008 · 10/9/21

Haffaz Aladeen đã viết:
Tuyệt vời! em cảm ơn anh nhiều.

Bạn thay code trong file bằng code này. Nó thực hiện luôn cái nhờ vả nhỏ kia đó --=0

Rich (BB code):

Sub testArray()
Dim Rng As Range, arr, arrOK, arrkq, strFind$, i&, k&, Dong&, Lrw&
Dim chk As Boolean

    arr = Sheet1.Range("B6:E" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row)
    arrOK = Sheet3.Range("B2:B" & Sheet3.Range("B" & Rows.Count).End(xlUp).Row)
    ReDim arrkq(1 To 7)
    Lrw = Sheet3.Cells(Rows.Count, "B").End(xlUp).Row + 1
    strFind = Sheet1.Range("C1")
    For i = 1 To UBound(arr)
        If arr(i, 1) = strFind Then
            arrkq(1) = arr(i, 1)
            arrkq(2) = arr(i, 2)
            arrkq(3) = arr(i, 3)
            arrkq(4) = Sheet1.Range("D2")
            arrkq(5) = Sheet1.Range("D3")
            arrkq(6) = Now
            arrkq(7) = Sheet1.Range("C4")
            Exit For
        End If
    Next
    Application.ScreenUpdating = False
    For i = 1 To UBound(arrOK)
        For k = 1 To UBound(arr)
            If arrOK(i, 1) = arr(k, 1) Then chk = True: Exit For
        Next
        If chk = False Then
            If Rng Is Nothing Then
                Set Rng = Sheet3.Range("B" & i + 1)
            Else
                Set Rng = Union(Rng, Sheet3.Range("B" & i + 1))
            End If
        End If
        chk = False
    Next
    Sheet3.Cells(Lrw, 2).Resize(1, UBound(arrkq)) = arrkq
    If Not Rng Is Nothing Then Rng.EntireRow.Delete xlUp
    Application.ScreenUpdating = True
End Sub

Haffaz Aladeen · 10/9/21

Maika8008 đã viết:
Bạn thay code trong file bằng code này. Nó thực hiện luôn cái nhờ vả nhỏ kia đó

Nhờ vã nhỏ nhỏ mà nó to khủng khiếp @$@^#

Em cảm ơn anh nhiều.

HieuCD · 11/9/21

Haffaz Aladeen đã viết:
Nhờ vã nhỏ nhỏ mà nó to khủng khiếp
Em cảm ơn anh nhiều.

File khá nặng mạng chập chờn nên không tải về được, code chưa xét trường hợp bấm nút lệnh chạy code nhiều lần lấy dữ liệu trùng

Mã:

Sub XYZ()
  Dim sArr(), aOK(), res(), dic As Object
  Dim strFind$, eRow&, sRow&, srOk&, i&, k&, j&

  strFind = Sheet1.Range("C1").Value
  sArr = Sheet1.Range("B6:E" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row)
  sRow = UBound(sArr)
 
  eRow = Sheet3.Range("B" & Rows.Count).End(xlUp).Row
  aOK = Sheet3.Range("B2:H" & eRow + 1).Value
  srOk = UBound(aOK)
 
  ReDim res(i To srOk, 1 To 7)
  Set dic = CreateObject("scripting.dictionary")
  For i = 1 To sRow
    dic.Item(sArr(i, 1)) = ""
    If sArr(i, 1) = strFind Then
      aOK(srOk, 1) = sArr(i, 1)
      aOK(srOk, 2) = sArr(i, 2)
      aOK(srOk, 3) = sArr(i, 3)
      aOK(srOk, 4) = Sheet1.Range("D2").Value
      aOK(srOk, 5) = Sheet1.Range("D3").Value
      aOK(srOk, 6) = Now
      aOK(srOk, 7) = Sheet1.Range("C4").Value
      Exit For
    End If
  Next i

  Application.ScreenUpdating = False
  For i = 1 To srOk
    If dic.exists(aOK(i, 1)) = True Then
      k = k + 1
      If k <> i Then
        For j = 1 To 7
          aOK(k, j) = aOK(i, j)
        Next j
      End If
    End If
  Next
  With Sheet3
    .Range("B2").Resize(k, 7) = aOK
    If k < srOk Then
      Range("B" & k + 2).Resize(eRow - k + 1, 7).ClearContents
    End If
  End With
  Application.ScreenUpdating = True
End Sub

Haffaz Aladeen · 14/9/21

HieuCD đã viết:
File khá nặng mạng chập chờn nên không tải về được, code chưa xét trường hợp bấm nút lệnh chạy code nhiều lần lấy dữ liệu trùng

Em cảm ơn nhiều ạ. Em thấy sử dụng Dictionary cho tốt độ rất tốt. Nhưng sao code chạy không đúng như ý em ạ. Không biết em sử dụng đúng không.
Em tự ngâm cứu để sửa theo ý mình, nhưng thật sự ko thể hiểu nhanh được. Em gửi lại file .xlsm, nhờ anh xem lại giúp em với ạ. Cảm ơn anh nhiều!

HieuCD · 14/9/21

Haffaz Aladeen đã viết:
Em cảm ơn nhiều ạ. Em thấy sử dụng Dictionary cho tốt độ rất tốt. Nhưng sao code chạy không đúng như ý em ạ. Không biết em sử dụng đúng không.
Em tự ngâm cứu để sửa theo ý mình, nhưng thật sự ko thể hiểu nhanh được. Em gửi lại file .xlsm, nhờ anh xem lại giúp em với ạ. Cảm ơn anh nhiều!

Ý bạn muốn kết quả như thế nào? tạo thêm 1 sheet với kết quả mong muốn và gởi lại file

Haffaz Aladeen · 14/9/21

HieuCD đã viết:
Ý bạn muốn kết quả như thế nào? tạo thêm 1 sheet với kết quả mong muốn và gởi lại file

Em xin lỗi vì trình bày cùi bắp quá :wallbash:

, em gửi file lại nhé anh, em có mô tả thêm ở trong file đó ạ. Em cảm ơn nhiều nhiều

HieuCD · 15/9/21

Haffaz Aladeen đã viết:
Em xin lỗi vì trình bày cùi bắp quá , em gửi file lại nhé anh, em có mô tả thêm ở trong file đó ạ. Em cảm ơn nhiều nhiều

Chỉnh lại code

Mã:

Sub XYZ()
  Dim sArr(), aOK(), res(), dic As Object
  Dim strFind$, eRow&, sRow&, srOk&, i&, k&, j&

  strFind = Sheet1.Range("C1").Value
  sArr = Sheet1.Range("B6:E" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row)
  sRow = UBound(sArr)
 
  eRow = Sheet3.Range("B" & Rows.Count).End(xlUp).Row
  aOK = Sheet3.Range("B2:H" & eRow + 1).Value
  srOk = UBound(aOK)
 
  ReDim res(i To srOk, 1 To 7)
  Set dic = CreateObject("scripting.dictionary")
  For i = 1 To sRow
    dic.Item(sArr(i, 1)) = ""
    If aOK(srOk, 1) = Empty Then
      If sArr(i, 1) = strFind Then
        aOK(srOk, 1) = sArr(i, 1)
        aOK(srOk, 2) = sArr(i, 2)
        aOK(srOk, 3) = sArr(i, 3)
        aOK(srOk, 4) = Sheet1.Range("D2").Value
        aOK(srOk, 5) = Sheet1.Range("D3").Value
        aOK(srOk, 6) = Now
        aOK(srOk, 7) = Sheet1.Range("C4").Value
      End If
    End If
  Next i
  Application.ScreenUpdating = False
  For i = 1 To srOk
    If dic.exists(aOK(i, 1)) = True Then
      k = k + 1
      If k <> i Then
        For j = 1 To 7
          aOK(k, j) = aOK(i, j)
        Next j
      End If
    End If
  Next
  With Sheet3
    .Range("B2").Resize(k, 7) = aOK
    If k < srOk Then
      .Range("B" & k + 2).Resize(eRow - k + 1, 7).ClearContents
    End If
  End With
  Application.ScreenUpdating = True
End Sub

VetMini · 15/9/21

HieuCD đã viết:
Application.ScreenUpdating = False

For i = 1 To srOk
If dic.exists(aOK(i, 1)) = True Then
k = k + 1
If k <> i Then
For j = 1 To 7
aOK(k, j) = aOK(i, j)
Next j
End If
End If
Next
With Sheet3
.Range("B2").Resize(k, 7) = aOK
If k < srOk Then
.Range("B" & k + 2).Resize(eRow - k + 1, 7).ClearContents
End If
End With
Application.ScreenUpdating = True
End Sub

Đặt screenupdating vào lúc thực sự update trên bảng tính chứ.
(theo nguyên tắc "đêm dài lắm mộng", đặt code càng nhiều ở giữa hai lệnh screenupdating càng nguy hiểm)

Mách nhỏ: A-OK là trạng từ dùng để diễn tả trạng thái trên OK một bậc.

batman1 · 15/9/21

VetMini đã viết:
Mách nhỏ: A-OK là trạng từ dùng để diễn tả trạng thái trên OK một bậc.

Trạng từ và tính từ thường có trạng thái Bình thường, Hơn và Nhất: Cô Vân xinh đẹp, cô Hoa xinh đẹp hơn, còn cô Lan xinh đẹp nhất.
OK -> A-OK -> ???

VetMini · 15/9/21

batman1 đã viết:
Trạng từ và tính từ thường có trạng thái Bình thường, Hơn và Nhất: Cô Vân xinh đẹp, cô Hoa xinh đẹp hơn, còn cô Lan xinh đẹp nhất.
OK -> A-OK -> ???

Được -> được lắm.

Chuyễn code bình thường sang mảng để tăng tốc độ

Thành viên mới

File đính kèm

/(hông là gì!

Thành viên mới

File đính kèm

/(hông là gì!

Thành viên gạo cội

File đính kèm

Ăn cùng góc phố

Thành viên gạo cội

Ăn cùng góc phố

Thành viên gạo cội

Thành viên mới

Thành viên gạo cội

Thành viên mới

Chuyên gia GPE

Thành viên mới

File đính kèm

Chuyên gia GPE

Thành viên mới

File đính kèm

Chuyên gia GPE

Ăn cùng góc phố

Thành viên gạo cội

Ăn cùng góc phố