Tim giá trị ngày nhỏ nhất và lớn nhất bang code (1 người xem)

cachabu · 21/12/14

Chào các bác
em có bài này do dùng công thức thì dữ liệu nặng quá chạy chậm quá, vậy nhờ các bác giúp e cái code cho nó nhẹ cái file tí nhé.
Yêu cầu là tìm giá trị ngày nhỏ nhất, lớn nhất theo điều kiện.

Cám ơn

hungpecc1 · 21/12/14

cachabu đã viết:
Chào các bác
em có bài này do dùng công thức thì dữ liệu nặng quá chạy chậm quá, vậy nhờ các bác giúp e cái code cho nó nhẹ cái file tí nhé.
Yêu cầu là tìm giá trị ngày nhỏ nhất, lớn nhất theo điều kiện.

Cám ơn

bạn tham khảo công cụ Consolidate có sẵn của Excel, nếu không đáp ứng được thì chuyển sang phương án dùng code

katylove83 · 21/12/14

hungpecc1 đã viết:
bạn tham khảo công cụ Consolidate có sẵn của Excel, nếu không đáp ứng được thì chuyển sang phương án dùng code

cám ơn bạn nhưng trong trường hợp này mình cần cái code bạn giúp mình nhé

Quang_Hải · 21/12/14

cachabu đã viết:
Chào các bác
em có bài này do dùng công thức thì dữ liệu nặng quá chạy chậm quá, vậy nhờ các bác giúp e cái code cho nó nhẹ cái file tí nhé.
Yêu cầu là tìm giá trị ngày nhỏ nhất, lớn nhất theo điều kiện.

Cám ơn

PHP:

Sub MinAndmax()
Dim arr(), D1 As Object, D2 As Object, i, tem
Set D1 = CreateObject("scripting.dictionary")
Set D2 = CreateObject("scripting.dictionary")
With Sheet1
   arr = .Range("A4", .[D65536].End(3)).Value
End With
For i = 1 To UBound(arr)
   tem = arr(i, 1)
   If Not D1.exists(arr(i, 1)) Then
      D1.Add tem, arr(i, 4)
      D2.Add tem, arr(i, 4)
   Else
      If D1.Item(tem) < arr(i, 4) Then D1.Item(tem) = arr(i, 4)
      If D2.Item(tem) > arr(i, 4) Then D2.Item(tem) = arr(i, 4)
   End If
Next
Sheet2.[A4].Resize(D1.Count) = Application.Transpose(D1.keys)
Sheet2.[B4].Resize(D1.Count) = Application.Transpose(D1.items)
Sheet2.[C4].Resize(D1.Count) = Application.Transpose(D2.items)
End Sub

cachabu · 21/12/14

quanghai1969 đã viết:

PHP:

Sub MinAndmax()
Dim arr(), D1 As Object, D2 As Object, i, tem
Set D1 = CreateObject("scripting.dictionary")
Set D2 = CreateObject("scripting.dictionary")
With Sheet1
   arr = .Range("A4", .[D65536].End(3)).Value
End With
For i = 1 To UBound(arr)
   tem = arr(i, 1)
   If Not D1.exists(arr(i, 1)) Then
      D1.Add tem, arr(i, 4)
      D2.Add tem, arr(i, 4)
   Else
      If D1.Item(tem) < arr(i, 4) Then D1.Item(tem) = arr(i, 4)
      If D2.Item(tem) > arr(i, 4) Then D2.Item(tem) = arr(i, 4)
   End If
Next
Sheet2.[A4].Resize(D1.Count) = Application.Transpose(D1.keys)
Sheet2.[B4].Resize(D1.Count) = Application.Transpose(D1.items)
Sheet2.[C4].Resize(D1.Count) = Application.Transpose(D2.items)
End Sub

chào anh hải, code của anh dùng ok lắm, tuy nhiên không hiểu sao lại tại chổ cho ra kết quả thì nó định dạng tháng trước ngày, mặc dù e đã định dạng lại là dd/mm/yyy rồi , a xem giúp em lỗi này vơi nhé

Quang_Hải · 21/12/14

cachabu đã viết:
chào anh hải, code của anh dùng ok lắm, tuy nhiên không hiểu sao lại tại chổ cho ra kết quả thì nó định dạng tháng trước ngày, mặc dù e đã định dạng lại là dd/mm/yyy rồi , a xem giúp em lỗi này vơi nhé

PHP:

Sub MinAndmax()
Dim arr(), i, x, tem
Dim kq(1 To 10000, 1 To 5), k
With Sheet1
   arr = .Range("A4", .[D65536].End(3)).Value
End With
With CreateObject("scripting.dictionary")
For i = 1 To UBound(arr)
   tem = arr(i, 1)
   If Not .exists(arr(i, 1)) Then
      k = k + 1
      .Add tem, k
      kq(k, 1) = tem
      kq(k, 4) = arr(i, 4)
      kq(k, 5) = arr(i, 4)
   Else
      x = .Item(tem)
      If kq(x, 4) < arr(i, 4) Then kq(x, 4) = arr(i, 4)
      If kq(x, 5) > arr(i, 4) Then kq(x, 5) = arr(i, 4)
   End If
Next
End With
Sheet2.[A4].Resize(k, 5) = kq
End Sub

cachabu · 21/12/14

quanghai1969 đã viết:

PHP:

Sub MinAndmax()
Dim arr(), i, x, tem
Dim kq(1 To 10000, 1 To 5), k
With Sheet1
   arr = .Range("A4", .[D65536].End(3)).Value
End With
With CreateObject("scripting.dictionary")
For i = 1 To UBound(arr)
   tem = arr(i, 1)
   If Not .exists(arr(i, 1)) Then
      k = k + 1
      .Add tem, k
      kq(k, 1) = tem
      kq(k, 4) = arr(i, 4)
      kq(k, 5) = arr(i, 4)
   Else
      x = .Item(tem)
      If kq(x, 4) < arr(i, 4) Then kq(x, 4) = arr(i, 4)
      If kq(x, 5) > arr(i, 4) Then kq(x, 5) = arr(i, 4)
   End If
Next
End With
Sheet2.[A4].Resize(k, 5) = kq
End Sub

cám ơn anh , code chạy ok lắm thật là tuyệt vời, tuy nhiên anh ơi, có thể bỏ cái lọc duy nhất tại cột A sheet 2 được không, vì e muốn cột đó là sẽ tự nhập tay vào.

Quang_Hải · 21/12/14

cachabu đã viết:
cám ơn anh , code chạy ok lắm thật là tuyệt vời, tuy nhiên anh ơi, có thể bỏ cái lọc duy nhất tại cột A sheet 2 được không, vì e muốn cột đó là sẽ tự nhập tay vào.

Nếu dữ liệu cột A là duy nhất thì code thế này.

PHP:

Sub MinMax()
Dim Tam(), Kq(), Arr(), i, j, k, x
Tam = Sheet2.Range("A4", Sheet2.[A65536].End(3)).Value
ReDim Kq(1 To UBound(Tam), 1 To 2)
Arr = Sheet1.Range("A4", Sheet1.[D65536].End(3)).Value
With CreateObject("scripting.dictionary")
   For i = 1 To UBound(Tam)
      .Item(Tam(i, 1)) = i
      Kq(i, 2) = Date + 100000
   Next
   For i = 1 To UBound(Arr)
      If .exists(Arr(i, 1)) Then
         x = .Item(Arr(i, 1))
         If Arr(i, 4) > Kq(x, 1) Then
            Kq(x, 1) = Arr(i, 4)
         End If
         If Arr(i, 4) < Kq(x, 2) Then
            Kq(x, 2) = Arr(i, 4)
         End If
      End If
   Next
End With
Sheet2.[B4].Resize(UBound(Tam), 2) = Kq
End Sub

VetMini · 21/12/14

katylove83 đã viết:
cám ơn bạn nhưng trong trường hợp này mình cần cái code bạn giúp mình nhé

Cho thắc mắc chút: Ai là người hỏi trong bài này vậy?

cachabu · 21/12/14

VetMini đã viết:
Cho thắc mắc chút: Ai là người hỏi trong bài này vậy?

chắc cả 2 anh ơi mình hỏi người ta vào hỏi thêm

cachabu · 21/12/14

quanghai1969 đã viết:

Nếu dữ liệu cột A là duy nhất thì code thế này.

PHP:

Sub MinMax()
Dim Tam(), Kq(), Arr(), i, j, k, x
Tam = Sheet2.Range("A4", Sheet2.[A65536].End(3)).Value
ReDim Kq(1 To UBound(Tam), 1 To 2)
Arr = Sheet1.Range("A4", Sheet1.[D65536].End(3)).Value
With CreateObject("scripting.dictionary")
   For i = 1 To UBound(Tam)
      .Item(Tam(i, 1)) = i
      Kq(i, 2) = Date + 100000
   Next
   For i = 1 To UBound(Arr)
      If .exists(Arr(i, 1)) Then
         x = .Item(Arr(i, 1))
         If Arr(i, 4) > Kq(x, 1) Then
            Kq(x, 1) = Arr(i, 4)
         End If
         If Arr(i, 4) < Kq(x, 2) Then
            Kq(x, 2) = Arr(i, 4)
         End If
      End If
   Next
End With
Sheet2.[B4].Resize(UBound(Tam), 2) = Kq
End Sub

anh làm ơn cho em hỏi tí đoạn này "Kq(i, 2) = Date + 100000" có nghĩa là thế nào vậy ko hiểu 100000 là để làm gì nhờ anh giải thích giúp
cám ơn

Quang_Hải · 22/12/14

cachabu đã viết:
anh làm ơn cho em hỏi tí đoạn này "Kq(i, 2) = Date + 100000" có nghĩa là thế nào vậy ko hiểu 100000 là để làm gì nhờ anh giải thích giúp
cám ơn

Ai biết đâu. Sao không thử bỏ nó ra hoặc thay con số khác vào coi nó ra cái quái gì. Từ từ nghiên cứu nha.
..............
Thật ra viết như thế là viết ẩu, nên sửa lại thế này

PHP:

Sub MinMax()
Dim Tam(), Kq(), Arr(), i,  x
Tam = Sheet2.Range("A4", Sheet2.[A65536].End(3)).Value
ReDim Kq(1 To UBound(Tam), 1 To 2)
Arr = Sheet1.Range("A4", Sheet1.[D65536].End(3)).Value
With CreateObject("scripting.dictionary")
   For i = 1 To UBound(Tam)
      .Item(Tam(i, 1)) = i
   Next
   For i = 1 To UBound(Arr)
      If .exists(Arr(i, 1)) Then
         x = .Item(Arr(i, 1))
         If Arr(i, 4) > Kq(x, 1) Then
            Kq(x, 1) = Arr(i, 4)
         End If
         If Kq(x, 2) = "" Then Kq(x, 2) = Arr(i, 4)
         If Arr(i, 4) < Kq(x, 2) Then
            Kq(x, 2) = Arr(i, 4)
         End If
      End If
   Next
End With
Sheet2.[B4].Resize(UBound(Tam), 2) = Kq
End Sub

hungpecc1 · 22/12/14

cachabu đã viết:
cám ơn anh , code chạy ok lắm thật là tuyệt vời, tuy nhiên anh ơi, có thể bỏ cái lọc duy nhất tại cột A sheet 2 được không, vì e muốn cột đó là sẽ tự nhập tay vào.

Tại sheet3 trong file đính kèm,bạn lần lượt gõ Q1, Q2 ,Q3 vào các ô tại cột A thử xem!
lưu ý : khi mở file nhớ enable contents nhé !

cachabu · 24/12/14

quanghai1969 đã viết:
Ai biết đâu. Sao không thử bỏ nó ra hoặc thay con số khác vào coi nó ra cái quái gì. Từ từ nghiên cứu nha.
..............
Thật ra viết như thế là viết ẩu, nên sửa lại thế này

PHP:

Sub MinMax() Dim Tam(), Kq(), Arr(), i, x Tam = Sheet2.Range("A4", Sheet2.[A65536].End(3)).Value ReDim Kq(1 To UBound(Tam), 1 To 2) Arr = Sheet1.Range("A4", Sheet1.[D65536].End(3)).Value With CreateObject("scripting.dictionary") For i = 1 To UBound(Tam) .Item(Tam(i, 1)) = i Next For i = 1 To UBound(Arr) If .exists(Arr(i, 1)) Then x = .Item(Arr(i, 1)) If Arr(i, 4) > Kq(x, 1) Then Kq(x, 1) = Arr(i, 4) End If If Kq(x, 2) = "" Then Kq(x, 2) = Arr(i, 4) If Arr(i, 4) < Kq(x, 2) Then Kq(x, 2) = Arr(i, 4) End If End If Next End With Sheet2.[B4].Resize(UBound(Tam), 2) = Kq End Sub

anh hải ơi, code của anh chạy ok luôn cám ơn anh nhiều

cachabu · 24/12/14

hungpecc1 đã viết:
tại sheet3 trong file đính kèm,bạn lần lượt gõ q1, q2 ,q3 vào các ô tại cột a thử xem!
Lưu ý : Khi mở file nhớ enable contents nhé !

code này thi đúng rồi anh ơi, mà công nhận cái ado đọc khó hiểu thật
cám ơn anh

Tim giá trị ngày nhỏ nhất và lớn nhất bang code (1 người xem)

Người dùng đang xem chủ đề này

cachabu

Thành viên hoạt động

File đính kèm

hungpecc1

Thành viên gắn bó

katylove83

Thành viên hoạt động

Quang_Hải

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

cachabu

Thành viên hoạt động

Quang_Hải

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

cachabu

Thành viên hoạt động

Quang_Hải

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

VetMini

Đang đi tìm hòn đá

cachabu

Thành viên hoạt động

cachabu

Thành viên hoạt động

Quang_Hải

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

hungpecc1

Thành viên gắn bó

File đính kèm

cachabu

Thành viên hoạt động

cachabu

Thành viên hoạt động

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Thời gian đếm ngược.