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

Blue Softs Liên hệ QC

Haffaz Aladeen

Thành viên mới
Tham gia
11/7/18
Bài viết
41
Được thích
5
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 ạ!
 

File đính kèm

  • PK.xls
    3.7 MB · Đọc: 10

SA_DQ

/(hông là gì!
Thành viên danh dự
Tham gia
8/6/06
Bài viết
12,694
Được thích
19,353
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!
 
Upvote 0

Haffaz Aladeen

Thành viên mới
Tham gia
11/7/18
Bài viết
41
Được thích
5
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::wallbash::wallbash:
 

File đính kèm

  • PK.xls
    3.7 MB · Đọc: 12
Upvote 0

SA_DQ

/(hông là gì!
Thành viên danh dự
Tham gia
8/6/06
Bài viết
12,694
Được thích
19,353
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
 
Upvote 0

Maika8008

Thành viên gắn bó
Tham gia
12/6/20
Bài viết
2,550
Được thích
2,819
Donate (Momo)
Donate
Giới tính
Nam
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.
 

File đính kèm

  • PK_Haffaz Aladeen.xls
    3.6 MB · Đọc: 15
Upvote 0

Maika8008

Thành viên gắn bó
Tham gia
12/6/20
Bài viết
2,550
Được thích
2,819
Donate (Momo)
Donate
Giới tính
Nam
Upvote 0

VetMini

Chuyên gia GPE
Tham gia
21/12/12
Bài viết
12,353
Được thích
15,918
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ì.
 
Upvote 0

Maika8008

Thành viên gắn bó
Tham gia
12/6/20
Bài viết
2,550
Được thích
2,819
Donate (Momo)
Donate
Giới tính
Nam
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.
 
Upvote 0

Maika8008

Thành viên gắn bó
Tham gia
12/6/20
Bài viết
2,550
Được thích
2,819
Donate (Momo)
Donate
Giới tính
Nam
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
 
Upvote 0

HieuCD

Chuyên gia GPE
Tham gia
14/9/10
Bài viết
8,494
Được thích
17,834
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
 
Upvote 0

Haffaz Aladeen

Thành viên mới
Tham gia
11/7/18
Bài viết
41
Được thích
5
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!
 

File đính kèm

  • PK.xlsm
    1 MB · Đọc: 5
Upvote 0

HieuCD

Chuyên gia GPE
Tham gia
14/9/10
Bài viết
8,494
Được thích
17,834
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
 
Upvote 0

Haffaz Aladeen

Thành viên mới
Tham gia
11/7/18
Bài viết
41
Được thích
5
Ý 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
 

File đính kèm

  • PK.xlsm
    1.9 MB · Đọc: 10
Upvote 0

HieuCD

Chuyên gia GPE
Tham gia
14/9/10
Bài viết
8,494
Được thích
17,834
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
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
 
Upvote 0

VetMini

Chuyên gia GPE
Tham gia
21/12/12
Bài viết
12,353
Được thích
15,918
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. :p
 
Upvote 0
Top Bottom