Code Tính giá trị để giảm dung lượng file (2 người xem)

[lhthai]

Hiện tại file dùng công thức nhiều nên file rất năng
Nay muốn chuyển thành code
Dán dự liệu vào những ô màu xanh sau đó nhấn nút KQ
Kết quả trả về ô màu vàng dựa theo điều kiện có sẵn
Các anh xem file đính kèm nha.

 

[lhthai]

Chào các Anh
Em mượn code trên diễn đàn chỉnh sữa lại nhưng không được
Anh nào biết sữa lại dùm.

Private Sub CommandButton21_Click()
Dim data(), kq(), i, j, k, C As Long, Tem As String
Dim Row As Object, Col As Object
Set Row = CreateObject("Scripting.Dictionary")
Set Col = CreateObject("Scripting.Dictionary")
data = Range("N4", [N4].End(xlToRight)).Value
For j = 1 To UBound(data, 2)
If Not Col.exists(data(1, j)) Then Col.Add data(1, j), j
Next j
data = Range("L5", [L5].End(xlDown)).Value
ReDim kq(1 To UBound(data, 1), 1 To UBound(data, 2))
For i = 1 To UBound(data, 1)
If Not Row.exists(data(i, 1)) Then Row.Add data(i, 1), i
Next i
For i = 1 To UBound(data, 1)
Tem = data(i, 1)
If Not Row.exists(Tem) Then Row.Add Tem, i
Next i
C = Range("C4").End(xlToRight).Column - 1
data = Range("B4", [B65536].End(xlUp)).Resize(, C).Value
For i = 2 To UBound(data, 1)
Tem = data(i, 1)
If Row.exists(Tem) Then
     For j = 2 To UBound(data, 2)
     If Col.exists(data(1, j)) Then
       C = Col.Item(data(1, j))
       kq(Row.Item(Tem), C) = data(i, j)
       End If
       Next j
       End If
       Next i
         Range("N5").Resize(UBound(data, 1), UBound(data, 2)) = kq
       Set Row = Nothing
       Set Col = Nothing
End Sub

 

[Let'GâuGâu]

Hiện tại file dùng công thức nhiều nên file rất năng
Nay muốn chuyển thành code
Dán dự liệu vào những ô màu xanh sau đó nhấn nút KQ
Kết quả trả về ô màu vàng dựa theo điều kiện có sẵn
Các anh xem file đính kèm nha.

ko biết là nó có nhanh được hơn cthuc ko, xem thử

Sub thucoi()
Dim arr, kq As Variant, tam(), i, j, k, l As Long, d As Object
arr = [B4:J15].Value
kq = [l4:u8].Value
ReDim tam(1 To UBound(arr) * UBound(arr, 2), 1 To 2)

For i = 2 To UBound(arr)
    For j = 2 To UBound(arr, 2)
        k = k + 1
        tam(k, 1) = arr(i, 1) & arr(1, j)
        tam(k, 2) = arr(i, j)
    Next j
Next i

For i = 2 To UBound(kq)
    For j = 3 To UBound(kq, 2)
        For l = 1 To UBound(tam)
            If kq(i, 1) & kq(1, j) = tam(l, 1) Then kq(i, j) = tam(l, 2) * kq(i, 2): Exit For
        Next l
    Next j
Next i

    [l4].Resize(i - 1, j - 1).Value = kq
        
Erase arr, kq, tam
End Sub

đi ngủ thôi,.......good9

 

[Quang_Hải]

Hiện tại file dùng công thức nhiều nên file rất năng
Nay muốn chuyển thành code
Dán dự liệu vào những ô màu xanh sau đó nhấn nút KQ
Kết quả trả về ô màu vàng dựa theo điều kiện có sẵn
Các anh xem file đính kèm nha.

Theo file mẫu thì code thế này là được

Sub test()
Dim Arr(), i&, j&, rng As Range
[N5:U100].ClearContents
Arr = Range("L5", [L65536].End(3)).Resize(, 9).Value
For i = 1 To UBound(Arr)
   Set rng = [B:B].Find(Arr(i, 1), , , 1)
   If Not rng Is Nothing Then
      For j = 3 To UBound(Arr, 2)
         Arr(i, j) = rng.Offset(, j - 2) * Arr(i, 2)
      Next
   End If
Next
[L5].Resize(i - 1, 9) = Arr
End Sub

 

[lhthai]

Theo file mẫu thì code thế này là được

Sub test()
Dim Arr(), i&, j&, rng As Range
[N5:U100].ClearContents
Arr = Range("L5", [L65536].End(3)).Resize(, 9).Value
For i = 1 To UBound(Arr)
   Set rng = [B:B].Find(Arr(i, 1), , , 1)
   If Not rng Is Nothing Then
      For j = 3 To UBound(Arr, 2)
         Arr(i, j) = rng.Offset(, j - 2) * Arr(i, 2)
      Next
   End If
Next
[L5].Resize(i - 1, 9) = Arr
End Sub

Bài này dùng Scripting.Dictionary được không
Anh có thể viết code dùng Dictionary để em tìm hiểu thêm về chức năng này
Rất cám ơn anh

 

[Let'GâuGâu]

Bài này dùng Scripting.Dictionary được không
Anh có thể viết code dùng Dictionary để em tìm hiểu thêm về chức năng này
Rất cám ơn anh

chắc nó cũng ko dính dánh gì tới dic, làm thử cho vui

Sub matrix()
Dim matr, data As Variant, i, j, kd, kc As Long, d_cot, d_dong As Object
matr = [b4:k15].Value
data = [l4:u8].Value
Set d_cot = CreateObject("Scripting.Dictionary")
Set d_dong = CreateObject("Scripting.Dictionary")

For i = 2 To UBound(matr)
    kd = kd + 1
    d_dong.Add matr(i, 1), kd
Next
For i = 2 To UBound(matr, 2)
    kc = kc + 1
    d_cot.Add matr(1, i), kc
Next
For i = 2 To UBound(data)
    For j = 3 To UBound(data, 2)
        data(i, j) = data(i, 2) * matr(d_dong.Item(data(i, 1)) + 1, d_cot.Item(data(1, j)) + 1)
    Next
Next
[l4].Resize(i - 1, j - 1).Value = data

Set d_cot = Nothing
Set d_dong = Nothing
Erase matr, data
End Sub

 

[lhthai]

Sub matrix()
Dim matr, data As Variant, i, j, kd, kc As Long, d_cot, d_dong As Object
matr = [b4:k15].Value
data = [l4:u8].Value
Set d_cot = CreateObject("Scripting.Dictionary")
Set d_dong = CreateObject("Scripting.Dictionary")

For i = 2 To UBound(matr)
    kd = kd + 1
    d_dong.Add matr(i, 1), kd
Next
For i = 2 To UBound(matr, 2)
    kc = kc + 1
    [COLOR=#ff0000]d_cot.Add matr(1, i), kc 'Chạy C trình báo lỗi cho này"[/COLOR]
Next
For i = 2 To UBound(data)
    For j = 3 To UBound(data, 2)
        data(i, j) = data(i, 2) * matr(d_dong.Item(data(i, 1)) + 1, d_cot.Item(data(1, j)) + 1)
    Next
Next
[l4].Resize(i - 1, j - 1).Value = data

Set d_cot = Nothing
Set d_dong = Nothing
Erase matr, data
End Sub

[/QUOTE]
cám ơn anh đã chỉ giúp.

 

[Let'GâuGâu]

    [COLOR=#ff0000]d_cot.Add matr(1, i), kc 'Chạy C trình báo lỗi cho này"[/COLOR]

  
[/QUOTE]

chạy trên file hiên tại bị lổi luôn hả? sao tôi chạy nó lại ko báo lổi ta?
có thể là do trùng, thêm cái lệnh này vào nó sẻ ko lấy trùng (mà nếuy có trùng thì nó sẻ ko cho kq đúng)
[code] if not d.exists then............

thêm đk vào ngăn trường hợp cell rổng

if not empty(data(i,j)) then

trao đổi thêm với bạn

 

[Quang_Hải]

Bài này dùng Scripting.Dictionary được không
Anh có thể viết code dùng Dictionary để em tìm hiểu thêm về chức năng này
Rất cám ơn anh

Theo quan điểm riêng của mình thì bài này mà nghiên cứu theo hướng dùng Dic thì phí sức phí thời gian vì nó chỉ làm cho code lu xu bu chứ chẳng ích gì. Mình là 1 trong những người khoái sử dụng công cụ Dic nhưng bài này mình không xài nó thì thiết nghĩ bạn cũng nên cho qua đi. Viết thì chắc là cũng có thể được nhưng mà có cần thiết không?
Quan điểm của mình là ngắn gọn, hiệu quả. Cho dù code có chạy chậm 1 vài giây cũng chẳng sao.

 

[lhthai]

chạy trên file hiên tại bị lổi luôn hả? sao tôi chạy nó lại ko báo lổi ta?
có thể là do trùng, thêm cái lệnh này vào nó sẻ ko lấy trùng (mà nếuy có trùng thì nó sẻ ko cho kq đúng)

 if not d.exists then............

thêm đk vào ngăn trường hợp cell rổng

if not empty(data(i,j)) then

trao đổi thêm với bạn

Cám ơn bạn mình sẽ kiểm tra xem sao
Bạn có thể cho mình 1 bài test về sử dụng Dic được không.

 

[Let'GâuGâu]

Cám ơn bạn mình sẽ kiểm tra xem sao
Bạn có thể cho mình 1 bài test về sử dụng Dic được không.

bạn gõ tìm trên diễn đàn, có nhiều mà................
hay là lục mấy bài viết cũ của anh QuangHai, trùm về dic luôn đó
chúc bạn thành công

 

[lhthai]

Theo file mẫu thì code thế này là được

Sub test()
Dim Arr(), i&, j&, rng As Range
[N5:U100].ClearContents
Arr = Range("L5", [L65536].End(3)).Resize(, 9).Value
For i = 1 To UBound(Arr)
   Set rng = [B:B].Find(Arr(i, 1), , , 1)
   If Not rng Is Nothing Then
      For j = 3 To UBound(Arr, 2)
         Arr(i, j) = rng.Offset(, j - 2) * Arr(i, 2)
      Next
   End If
Next
[L5].Resize(i - 1, 9) = Arr
End Sub

Chào Anh QuangHai
Trường hợp anh viết tương tự hàm Vlookup nhưng em muốn kết quả giống hàm Index
Chẳng hạn em muốn thay đổi thứ tự tên dòng N4:U4
Nhờ anh chỉ thêm.

 

[Quang_Hải]

Chào Anh QuangHai
Trường hợp anh viết tương tự hàm Vlookup nhưng em muốn kết quả giống hàm Index
Chẳng hạn em muốn thay đổi thứ tự tên dòng N4:U4
Nhờ anh chỉ thêm.

Thì cũng nhiêu đó thôi

Sub test()
on error resume next
Dim Arr(), i&, j&, c&, rng As Range
[N5:U100].ClearContents
Arr = Range("L4", [L65536].End(3)).Resize(, 9).Value
For i = 2 To UBound(Arr)
   Set rng = [B:B].Find(Arr(i, 1), , , 1)
   If Not rng Is Nothing Then
      For j = 3 To UBound(Arr, 2)
         c = Rows(4).Find(Arr(1, j), , , 1).Column - 2
         Arr(i, j) = rng.Offset(, c) * Arr(i, 2)
      Next
   End If
Next
[L4].Resize(i - 1, 9) = Arr
End Sub

 

[lhthai]

Thì cũng nhiêu đó thôi

Sub test()
on error resume next
Dim Arr(), i&, j&, c&, rng As Range
[N5:U100].ClearContents
Arr = Range("L4", [L65536].End(3)).Resize(, 9).Value
For i = 2 To UBound(Arr)
   Set rng = [B:B].Find(Arr(i, 1), , , 1)
   If Not rng Is Nothing Then
      For j = 3 To UBound(Arr, 2)
         c = Rows(4).Find(Arr(1, j), , , 1).Column - 2
         Arr(i, j) = rng.Offset(, c) * Arr(i, 2)
      Next
   End If
Next
[L4].Resize(i - 1, 9) = Arr
End Sub

Cám ơn anh rất nhiều

 

[Quang_Hải]

Bài này dùng Scripting.Dictionary được không
Anh có thể viết code dùng Dictionary để em tìm hiểu thêm về chức năng này
Rất cám ơn anh

Nếu muốn dùng Dic thì mình thử 1 cái cho xem

Sub test2()
Dim Dic As Object, Tam
Dim Arr(), i&, j&, c&, rng As Range
Set Dic = CreateObject("scripting.dictionary")
Tam = [C4:J4].Value
[N5:U100].ClearContents
For j = 1 To UBound(Tam, 2)
   Dic(Tam(1, j)) = j
Next
Arr = Range("L4", [L65536].End(3)).Resize(, 10).Value
For i = 2 To UBound(Arr)
   Set rng = [B:B].Find(Arr(i, 1), , , 1)
   If Not rng Is Nothing Then
      For j = 3 To UBound(Arr, 2)
         If Dic.exists(Arr(1, j)) Then
            c = Dic.Item(Arr(1, j))
            Arr(i, j) = rng.Offset(, c) * Arr(i, 2)
         End If
      Next
   End If
Next
[L4].Resize(i - 1, 10) = Arr
End Sub

 

[lhthai]

Nếu muốn dùng Dic thì mình thử 1 cái cho xem

Sub test2()
Dim Dic As Object, Tam
Dim Arr(), i&, j&, c&, rng As Range
Set Dic = CreateObject("scripting.dictionary")
Tam = [C4:J4].Value
[N5:U100].ClearContents
For j = 1 To UBound(Tam, 2)
   Dic(Tam(1, j)) = j
Next
Arr = Range("L4", [L65536].End(3)).Resize(, 10).Value
For i = 2 To UBound(Arr)
   Set rng = [B:B].Find(Arr(i, 1), , , 1)
   If Not rng Is Nothing Then
      For j = 3 To UBound(Arr, 2)
         If Dic.exists(Arr(1, j)) Then
            c = Dic.Item(Arr(1, j))
            Arr(i, j) = rng.Offset(, c) * Arr(i, 2)
         End If
      Next
   End If
Next
[L4].Resize(i - 1, 10) = Arr
End Sub

Cám ơn anh nhiều
Trường hợp vùng điều kiện nằm ở 2 sheet khác nhau không thể viết hàm Index mình sử dụng Dic được không anh
Chẳng hạn như file đính kèm sau.