Dò tìm giảm giá bằng VBA (1 người xem)

Liên hệ QC

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

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
T

thao nguyen01

Thành viên thường trực
Tham gia
8/12/19
Bài viết
241
Được thích
30
Kính gửi anh/chị trên diễn đàn,

Em đang bị vướng vấn đề sau ạ:

Em muốn dò tìm cột giảm giá trong sheet Danh muc: Nếu ngày bên sheet Thống kê nằm trong khoảng ngày của Danh mục thì sẽ lấy cột Giảm giá ạ. Em có viết code nhưng chưa ra ạ. Anh/chị xem giúp em ạ. Em cảm ơn nhiều ạ.

Sub thongke03(Dic As Object, arr_D())
Dim i As Long, dcuoi As Long
Dim arr_N()
dcuoi = Sheet2.Range("G10000").End(xlUp).Row
arr_N = Sheet2.Range("G2:I" & dcuoi)
ReDim arr_D(1 To UBound(arr_N, 1), 1 To 3)
For i = 1 To UBound(arr_N, 1)
If Not Dic.exists(">=" & arr_N(i, 1) And "<=" & arr_N(i, 2)) Then
k = k + 1
Dic.Add ">=" & arr_N(i, 1) And "<=" & arr_N(i, 2), k
arr_D(k, 1) = arr_N(i, 1)
arr_D(k, 2) = arr_N(i, 2)
arr_D(k, 3) = arr_N(i, 3)
End If
Next
End Sub


Sub dotim()
Dim i As Long, dcuoi As Long, j As Long, ii As Long
Dim arr_N()
Dim arr_D(), arr_Dotim()
Dim Dic As Object
Set Dic = CreateObject("scripting.dictionary")
Call thongke03(Dic, arr_Dotim)

dcuoi = Sheet1.Range("C10000").End(xlUp).Row
arr_N = Sheet1.Range("C2:C" & dcuoi)
ReDim arr_D(1 To UBound(arr_N, 1), 1 To 2)

For i = 1 To UBound(arr_N, 1)
If Dic.exists(arr_N(i, 1)) Then
j = Dic.Item(arr_N(i, 1))
arr_D(i, 1) = arr_Dotim(j, 3)
End If
Next
Sheet1.Range("G2:H1000").Clear
Sheet1.Range("G2").Resize(UBound(arr_N, 1), 1) = arr_D
End Sub
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
Bạn xài tạm cái ni; Nếu là rùa thì báo để xài con dao bén hơn như bạn!
PHP: 
Sub GiamGia()
Dim J As Long, W As Integer, fDat As Date, lDat As Date, Dat As Date
Dim Cls As Range, Sh As Worksheet

Set Sh = ThisWorkbook.Worksheets("Danh Muc")   
With Sheets("Thong Ke")
    For Each Cls In .Range(.[C2], .[C2].End(xlDown))
        Dat = Cls.Value
        For J = 2 To Sh.[G2].End(xlDown).Row
            fDat = Sh.Cells(J, "G").Value:          lDat = Sh.Cells(J, "H").Value
            If Dat >= fDat And Dat <= lDat Then
                .Cells(Cls.Row, "G").Value = Sh.Cells(J, "I").Value
                .Cells(Cls.Row, "G").Interior.ColorIndex = 34 + J
            End If
        Next J
    Next Cls
  End With
End Sub
 
Upvote 0
thao nguyen01 đã viết:
Kính gửi anh/chị trên diễn đàn,

Em đang bị vướng vấn đề sau ạ:

Em muốn dò tìm cột giảm giá trong sheet Danh muc: Nếu ngày bên sheet Thống kê nằm trong khoảng ngày của Danh mục thì sẽ lấy cột Giảm giá ạ. Em có viết code nhưng chưa ra ạ. Anh/chị xem giúp em ạ. Em cảm ơn nhiều ạ.

Bạn xem thử
Nhấp chuột vào đây để mở rộng...
 

File đính kèm

Upvote 0
Góp vui thêm 1 cách:
PHP: 
Sub GiamGia()
Dim i As Long, j As Long, lr As Long
Dim Dic As Object
Dim tbGiamGia, tbThongKe, tbKetQua
Set Dic = CreateObject("scripting.dictionary")

With Sheets("danh muc")
    lr = .Range("G" & .Rows.Count).End(xlUp).Row
    tbGiamGia = .Range("G2:I" & lr).Value2
    For i = 1 To UBound(tbGiamGia)
        For j = tbGiamGia(i, 1) To tbGiamGia(i, 2)
          Dic.Item(j) = tbGiamGia(i, 3)
        Next
    Next i
End With

With Sheets("thong ke")
    lr = .Range("C" & .Rows.Count).End(xlUp).Row
    tbThongKe = .Range("C2:C" & lr).Value2
    lr = UBound(tbThongKe)
    ReDim tbKetQua(1 To lr, 1 To 1)
    
    For i = 1 To lr
        If Dic.exists(tbThongKe(i, 1)) Then
            tbKetQua(i, 1) = Dic.Item(tbThongKe(i, 1))
        End If
    Next i
    .Range("G2").Resize(lr, 1) = tbKetQua
End With

End Sub
 
Upvote 0
SA_DQ đã viết:
Bạn xài tạm cái ni; Nếu là rùa thì báo để xài con dao bén hơn như bạn!
PHP: 
Sub GiamGia()
Dim J As Long, W As Integer, fDat As Date, lDat As Date, Dat As Date
Dim Cls As Range, Sh As Worksheet

Set Sh = ThisWorkbook.Worksheets("Danh Muc")  
With Sheets("Thong Ke")
    For Each Cls In .Range(.[C2], .[C2].End(xlDown))
        Dat = Cls.Value
        For J = 2 To Sh.[G2].End(xlDown).Row
            fDat = Sh.Cells(J, "G").Value:          lDat = Sh.Cells(J, "H").Value
            If Dat >= fDat And Dat <= lDat Then
                .Cells(Cls.Row, "G").Value = Sh.Cells(J, "I").Value
                .Cells(Cls.Row, "G").Interior.ColorIndex = 34 + J
            End If
        Next J
    Next Cls
  End With
End Sub
Nhấp chuột vào đây để mở rộng...

Dạ, con cảm ơn Thầy @SA_DQ nhiều lắm ạ.
Bài đã được tự động gộp:


Dạ, em cảm ơn anh @Nhất Chi Lan nhiều ạ
Bài đã được tự động gộp:

phuocam đã viết:
Góp vui thêm 1 cách:
PHP: 
Sub GiamGia()
Dim i As Long, j As Long, lr As Long
Dim Dic As Object
Dim tbGiamGia, tbThongKe, tbKetQua
Set Dic = CreateObject("scripting.dictionary")

With Sheets("danh muc")
    lr = .Range("G" & .Rows.Count).End(xlUp).Row
    tbGiamGia = .Range("G2:I" & lr).Value2
    For i = 1 To UBound(tbGiamGia)
        For j = tbGiamGia(i, 1) To tbGiamGia(i, 2)
          Dic.Item(j) = tbGiamGia(i, 3)
        Next
    Next i
End With

With Sheets("thong ke")
    lr = .Range("C" & .Rows.Count).End(xlUp).Row
    tbThongKe = .Range("C2:C" & lr).Value2
    lr = UBound(tbThongKe)
    ReDim tbKetQua(1 To lr, 1 To 1)
   
    For i = 1 To lr
        If Dic.exists(tbThongKe(i, 1)) Then
            tbKetQua(i, 1) = Dic.Item(tbThongKe(i, 1))
        End If
    Next i
    .Range("G2").Resize(lr, 1) = tbKetQua
End With

End Sub
Nhấp chuột vào đây để mở rộng...

Dạ, em cảm ơn anh nhiều ạ. Anh có thể xem giúp em nếu có thêm cột chương trình không ạ. Vì nếu nằm trong khoảng thời gian bên sheet Danhmuc sẽ lấy vào sheet Thong ke cột Giảm giá và tên chương trình ạ. Vì em đang thắc mắc nếu dò tìm lấy 2 cột thì đoạn code sau sẽ thay đổi như thế nào ạ
For i = 1 To UBound(tbGiamGia)
For j = tbGiamGia(i, 1) To tbGiamGia(i, 2)
Dic.Item(j) = tbGiamGia(i, 3)
Next
Next i
Nếu có thể, anh xem giúp em ạ. Em cảm ơn anh nhiều ạ.
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Thay đổi một chút.
PHP: 
Sub GiamGia()
Dim i As Long, j As Long, lr As Long
Dim Dic As Object
Dim tbGiamGia, tbThongKe, tbKetQua
Set Dic = CreateObject("scripting.dictionary")

With Sheets("danh muc")
    lr = .Range("G" & .Rows.Count).End(xlUp).Row
    tbGiamGia = .Range("G2:J" & lr).Value2
    For i = 1 To UBound(tbGiamGia)
        For j = tbGiamGia(i, 1) To tbGiamGia(i, 2)
          Dic.Item(j) = Array(tbGiamGia(i, 3), tbGiamGia(i, 4))
        Next
    Next i
End With

With Sheets("thong ke")
    lr = .Range("C" & .Rows.Count).End(xlUp).Row
    tbThongKe = .Range("C2:C" & lr).Value2
    lr = UBound(tbThongKe)
    ReDim tbKetQua(1 To lr, 1 To 2)
  
    For i = 1 To lr
        If Dic.exists(tbThongKe(i, 1)) Then
            tbKetQua(i, 1) = Dic.Item(tbThongKe(i, 1))(0)
            tbKetQua(i, 2) = Dic.Item(tbThongKe(i, 1))(1)
        End If
    Next i
    .Range("G2").Resize(lr, 2) = tbKetQua
End With

End Sub
 
Upvote 0
phuocam đã viết:
Thay đổi một chút.
PHP: 
Sub GiamGia()
Dim i As Long, j As Long, lr As Long
Dim Dic As Object
Dim tbGiamGia, tbThongKe, tbKetQua
Set Dic = CreateObject("scripting.dictionary")

With Sheets("danh muc")
    lr = .Range("G" & .Rows.Count).End(xlUp).Row
    tbGiamGia = .Range("G2:J" & lr).Value2
    For i = 1 To UBound(tbGiamGia)
        For j = tbGiamGia(i, 1) To tbGiamGia(i, 2)
          Dic.Item(j) = Array(tbGiamGia(i, 3), tbGiamGia(i, 4))
        Next
    Next i
End With

With Sheets("thong ke")
    lr = .Range("C" & .Rows.Count).End(xlUp).Row
    tbThongKe = .Range("C2:C" & lr).Value2
    lr = UBound(tbThongKe)
    ReDim tbKetQua(1 To lr, 1 To 2)
 
    For i = 1 To lr
        If Dic.exists(tbThongKe(i, 1)) Then
            tbKetQua(i, 1) = Dic.Item(tbThongKe(i, 1))(0)
            tbKetQua(i, 2) = Dic.Item(tbThongKe(i, 1))(1)
        End If
    Next i
    .Range("G2").Resize(lr, 2) = tbKetQua
End With

End Sub
Nhấp chuột vào đây để mở rộng...

Dạ, em cảm ơn anh @phuocam nhiều lắm ạ.
 
Upvote 0
thao nguyen01 đã viết:
Kính gửi anh/chị trên diễn đàn,
Em đang bị vướng vấn đề sau ạ: Em muốn dò tìm cột giảm giá trong sheet Danh muc: Nếu ngày bên sheet Thống kê nằm trong khoảng ngày của Danh mục thì sẽ lấy cột Giảm giá ạ. Em có viết code nhưng chưa ra ạ. Anh/chị xem giúp em ạ. Em cảm ơn nhiều ạ.
Nhấp chuột vào đây để mở rộng...
Thử sử dụng hàm GiamGia, với điều kiện chọn một chương trình Khuyến mãi ở cột I.
Tôi làm với mục đích còn sử dụng PivotTable để tổng hợp số trường hợp được giảm giá theo từng chương trình Khuyến mãi.
 

File đính kèm

Upvote 0
thao nguyen01 đã viết:
Dạ, em cảm ơn anh @be09 nhiều ạ.
Nhấp chuột vào đây để mở rộng...
Để áp dụng cho nhiều chương trình khuyến mãi khác thì bạn sửa nội dung F3: F5 của sheet danh muc, tại đây tôi dùng Name có tên là Ten_ChuongTrinh để gán cho Validation ở cột I của sheet thong ke bạn chỉ việc chọn 1 chương trình phù hợp với 1 đợt khuyến mãi.
 
Upvote 0
be09 đã viết:
Để áp dụng cho nhiều chương trình khuyến mãi khác thì bạn sửa nội dung F3: F5 của sheet danh muc, tại đây tôi dùng Name có tên là Ten_ChuongTrinh để gán cho Validation ở cột I của sheet thong ke bạn chỉ việc chọn 1 chương trình phù hợp với 1 đợt khuyến mãi.
Nhấp chuột vào đây để mở rộng...

Dạ, em hiểu ý anh rùi ạ. Em cảm ơn anh nhiều lắm ạ.
 
Upvote 0
phuocam đã viết:
Thay đổi một chút.
PHP: 
Sub GiamGia()
Dim i As Long, j As Long, lr As Long
Dim Dic As Object
Dim tbGiamGia, tbThongKe, tbKetQua
Set Dic = CreateObject("scripting.dictionary")

With Sheets("danh muc")
    lr = .Range("G" & .Rows.Count).End(xlUp).Row
    tbGiamGia = .Range("G2:J" & lr).Value2
    For i = 1 To UBound(tbGiamGia)
        For j = tbGiamGia(i, 1) To tbGiamGia(i, 2)
          Dic.Item(j) = Array(tbGiamGia(i, 3), tbGiamGia(i, 4))
        Next
    Next i
End With

With Sheets("thong ke")
    lr = .Range("C" & .Rows.Count).End(xlUp).Row
    tbThongKe = .Range("C2:C" & lr).Value2
    lr = UBound(tbThongKe)
    ReDim tbKetQua(1 To lr, 1 To 2)
 
    For i = 1 To lr
        If Dic.exists(tbThongKe(i, 1)) Then
            tbKetQua(i, 1) = Dic.Item(tbThongKe(i, 1))(0)
            tbKetQua(i, 2) = Dic.Item(tbThongKe(i, 1))(1)
        End If
    Next i
    .Range("G2").Resize(lr, 2) = tbKetQua
End With

End Sub
Nhấp chuột vào đây để mở rộng...

Dạ, anh có thể xem giúp em thêm trường hợp là: array(Array(tbGiamGia(i, 3), tbGiamGia(i, 4))) chỉ lưu được 2 cột. Trường hợp em cần dò tìm 3 cột và đưa vào sheet thong ke thì em không thể dùng array được ạ. Khi nào anh có thời gian, anh xem giúp em ạ. Em cảm ơn anh nhiều ạ.
 
Upvote 0
phuocam đã viết:
Thay đổi một chút.
PHP: 
Sub GiamGia()
Dim i As Long, j As Long, lr As Long
Dim Dic As Object
Dim tbGiamGia, tbThongKe, tbKetQua
Set Dic = CreateObject("scripting.dictionary")

With Sheets("danh muc")
    lr = .Range("G" & .Rows.Count).End(xlUp).Row
    tbGiamGia = .Range("G2:J" & lr).Value2
    For i = 1 To UBound(tbGiamGia)
        For j = tbGiamGia(i, 1) To tbGiamGia(i, 2)
          Dic.Item(j) = Array(tbGiamGia(i, 3), tbGiamGia(i, 4))
        Next
    Next i
End With

With Sheets("thong ke")
    lr = .Range("C" & .Rows.Count).End(xlUp).Row
    tbThongKe = .Range("C2:C" & lr).Value2
    lr = UBound(tbThongKe)
    ReDim tbKetQua(1 To lr, 1 To 2)
 
    For i = 1 To lr
        If Dic.exists(tbThongKe(i, 1)) Then
            tbKetQua(i, 1) = Dic.Item(tbThongKe(i, 1))(0)
            tbKetQua(i, 2) = Dic.Item(tbThongKe(i, 1))(1)
        End If
    Next i
    .Range("G2").Resize(lr, 2) = tbKetQua
End With

End Sub
Nhấp chuột vào đây để mở rộng...
Dạ, em định viết giống như sau ạ:
If Not Dic.exists(....)Then
k = k + 1
Dic.Add ......,k
arr_D(k, 1) = arr_N(i, 1)
arr_D(k, 2) = arr_N(i, 2)
arr_D(k, 3) = arr_N(i, 3)
End If
Bai #1, Chỗ ..... em không biết điền arr_N(i,1) hay arr_N(i,2)... vô ạ, của anh là tbgiamgia. Vì công việc của em có nhiều khi dò lấy trên 2 kết quả. Bài này em vướng ở chỗ sheet thong ke và sheet danh muc, e dò ngày nhưng dò trong khoảng ạ. Em làm theo cách của anh dò đến kết quả thứ 3 không được ạ. E đưa vô array chỉ được 2 thôi ạ.
 
Upvote 0
Bạn thử Code này, có thể bạn sẽ dễ tùy chỉnh thêm nhiều cột kết quả hơn.
PHP: 
Option Explicit

Sub s_Gpe()
Dim Dic As Object, sArr(), dArr(), tArr()
Dim I As Long, J As Long, K As Long, R As Long
Set Dic = CreateObject("Scripting.Dictionary")
    ' ===========Sheet danh muc 4 cot'
    tArr = Sheets("danh muc").Range("G1", Sheets("danh muc").Range("G10000").End(xlUp)).Resize(, 4).Value
    If UBound(tArr) = 1 Then Exit Sub
    For I = 2 To UBound(tArr)
        For J = tArr(I, 1) To tArr(I, 2)
          Dic.Item(J) = I   '==========Cac ngay co chuong trinh khuyen mai'
        Next J
    Next I
With Sheets("thong ke")
    sArr = .Range("C2", .Range("C10000").End(xlUp)).Value
    R = UBound(sArr)
    ReDim dArr(1 To R, 1 To 2)      'Ket qua muon lay co 2 cot'
    For I = 1 To R
        If Dic.Exists(sArr(I, 1)) Then
            dArr(I, 1) = tArr(Dic.Item(sArr(I, 1)), 3)  'Ket qua cot 1:Giam gia'
            dArr(I, 2) = tArr(Dic.Item(sArr(I, 1)), 4)  'Ket qua cot 2:Ten Chuong trinh'
        End If
    Next I
    .Range("G2").Resize(R, 2) = dArr
End With
Set Dic = Nothing
End Sub
 
Upvote 0
Ba Tê đã viết:
Bạn thử Code này, có thể bạn sẽ dễ tùy chỉnh thêm nhiều cột kết quả hơn.
PHP: 
Option Explicit

Sub s_Gpe()
Dim Dic As Object, sArr(), dArr(), tArr()
Dim I As Long, J As Long, K As Long, R As Long
Set Dic = CreateObject("Scripting.Dictionary")
    ' ===========Sheet danh muc 4 cot'
    tArr = Sheets("danh muc").Range("G1", Sheets("danh muc").Range("G10000").End(xlUp)).Resize(, 4).Value
    If UBound(tArr) = 1 Then Exit Sub
    For I = 2 To UBound(tArr)
        For J = tArr(I, 1) To tArr(I, 2)
          Dic.Item(J) = I   '==========Cac ngay co chuong trinh khuyen mai'
        Next J
    Next I
With Sheets("thong ke")
    sArr = .Range("C2", .Range("C10000").End(xlUp)).Value
    R = UBound(sArr)
    ReDim dArr(1 To R, 1 To 2)      'Ket qua muon lay co 2 cot'
    For I = 1 To R
        If Dic.Exists(sArr(I, 1)) Then
            dArr(I, 1) = tArr(Dic.Item(sArr(I, 1)), 3)  'Ket qua cot 1:Giam gia'
            dArr(I, 2) = tArr(Dic.Item(sArr(I, 1)), 4)  'Ket qua cot 2:Ten Chuong trinh'
        End If
    Next I
    .Range("G2").Resize(R, 2) = dArr
End With
Set Dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...

Dạ, con làm theo cách của bác ra rồi ạ. Con cảm ơn bác @Ba Tê nhiều lắm ạ.
 
Upvote 0
thao nguyen01 đã viết:
Dạ, em định viết giống như sau ạ:
If Not Dic.exists(....)Then
k = k + 1
Dic.Add ......,k
arr_D(k, 1) = arr_N(i, 1)
arr_D(k, 2) = arr_N(i, 2)
arr_D(k, 3) = arr_N(i, 3)
End If
Bai #1, Chỗ ..... em không biết điền arr_N(i,1) hay arr_N(i,2)... vô ạ, của anh là tbgiamgia. Vì công việc của em có nhiều khi dò lấy trên 2 kết quả. Bài này em vướng ở chỗ sheet thong ke và sheet danh muc, e dò ngày nhưng dò trong khoảng ạ. Em làm theo cách của anh dò đến kết quả thứ 3 không được ạ. E đưa vô array chỉ được 2 thôi ạ.
Nhấp chuột vào đây để mở rộng...
Thử code
Cột G sheet "danh muc" phải xếp thứ tự theo thời gian
Mã: 
Sub ABC()
  Dim i&, j&, sRow&, ik
  Dim Rng As Range, ngayMua(), Res()
  Const sCol& = 3 'So cot lay du lieu

  With Sheets("danh muc")
    Set Rng = .Range("G2", .Range("G" & .Rows.Count).End(xlUp))
  End With
  With Sheets("thong ke")
    ngayMua = .Range("C2", .Range("C" & .Rows.Count).End(xlUp)).Value2
    sRow = UBound(ngayMua)
    ReDim Res(1 To sRow, 1 To sCol)
    For i = 1 To sRow
      ik = Application.Match(ngayMua(i, 1), Rng.Value2)
      If IsNumeric(ik) Then
        If ngayMua(i, 1) <= Rng(ik, 1).Offset(, 1).Value2 Then
          For j = 1 To sCol
            Res(i, j) = Rng(ik, 1).Offset(, j + 1).Value2
          Next j
        End If
      End If
    Next i
    .Range("G2").Resize(sRow, sCol) = Res
  End With
End Sub
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
HieuCD đã viết:
Thử code
Mã: 
Sub ABC()
  Dim i&, j&, sRow&, ik
  Dim Rng As Range, ngayMua(), Res()
  Const sCol& = 3 'So cot lay du lieu

  With Sheets("danh muc")
    Set Rng = .Range("G2", .Range("G" & .Rows.Count).End(xlUp))
  End With
  With Sheets("thong ke")
    ngayMua = .Range("C2", .Range("C" & .Rows.Count).End(xlUp)).Value2
    sRow = UBound(ngayMua)
    ReDim Res(1 To sRow, 1 To sCol)
    For i = 1 To sRow
      ik = Application.Match(ngayMua(i, 1), Rng.Value2)
      If IsNumeric(ik) Then
        If ngayMua(i, 1) <= Rng(ik, 1).Offset(, 1).Value2 Then
          For j = 1 To sCol
            Res(i, j) = Rng(ik, 1).Offset(, j + 1).Value2
          Next j
        End If
      End If
    Next i
    .Range("G2").Resize(sRow, sCol) = Res
  End With
End Sub
Nhấp chuột vào đây để mở rộng...

dạ, em cảm ơn Thầy @HieuCD nhiều ạ.
Bài đã được tự động gộp:

Ba Tê đã viết:
Lỡ khai báo biến K mà không xài.
Xem file này "vui" hơn nè.
Nhấp chuột vào đây để mở rộng...

Dạ, con cảm ơn Bác@ba tê nhiều ạ. Nhưng bác ơi, con có viết code vào file dò tìm thuế TNCN mà trước đây con dùng nhiều IF lồng nhau để viết ạ. Con thấy cách dò giống file này nhưng khi con chạy code, code quay vòng vòng, không ra kết quả ạ. Bác có thể xem giúp con với ạ. Con định mở chủ đề khác nhưng vì con thấy cách vận dụng code và ví dụ giống bài trên ạ.

Sub thongke03(Dic As Object, arr_D())
Dim i As Long, dcuoi As Long
Dim arr_N()

dcuoi = Sheet1.Range("G10000").End(xlUp).Row
arr_N = Sheet1.Range("G2:J" & dcuoi)
ReDim arr_D(1 To UBound(arr_N, 1), 1 To 3)
For i = 1 To UBound(arr_N, 1)
For j = arr_N(i, 1) To arr_N(i, 2)
Dic.Item(j) = i
Next

Next
End Sub
Sub dotim()
Dim i As Long, dcuoi As Long, j As Long, ii As Long
Dim arr_N()
Dim arr_D(), arr_Dotim()
Dim Dic As Object
Set Dic = CreateObject("scripting.dictionary")
Call thongke03(Dic, arr_Dotim)

dcuoi = Sheet1.Range("B10000").End(xlUp).Row
arr_N = Sheet1.Range("B2:B" & dcuoi)
ReDim arr_D(1 To UBound(arr_N, 1), 1 To 2)

For i = 1 To UBound(arr_N, 1)
If Dic.exists(arr_N(i, 1)) Then
j = Dic.Item(arr_N(i, 1))
arr_D(i, 1) = arr_Dotim(j, 3)
arr_D(i, 2) = arr_Dotim(j, 4)

End If
Next
Sheet1.Range("C2:D1000").Clear
Sheet1.Range("C2").Resize(UBound(arr_N, 1), 2) = arr_D
End Sub
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
thao nguyen01 đã viết:
dạ, em cảm ơn Thầy @HieuCD nhiều ạ.
Bài đã được tự động gộp:



Dạ, con cảm ơn Bác@ba tê nhiều ạ. Nhưng bác ơi, con có viết code vào file dò tìm thuế TNCN mà trước đây con dùng nhiều IF lồng nhau để viết ạ. Con thấy cách dò giống file này nhưng khi con chạy code, code quay vòng vòng, không ra kết quả ạ. Bác có thể xem giúp con với ạ. Con định mở chủ đề khác nhưng vì con thấy cách vận dụng code và ví dụ giống bài trên ạ.

Sub thongke03(Dic As Object, arr_D())
Dim i As Long, dcuoi As Long
Dim arr_N()

dcuoi = Sheet1.Range("G10000").End(xlUp).Row
arr_N = Sheet1.Range("G2:J" & dcuoi)
ReDim arr_D(1 To UBound(arr_N, 1), 1 To 3)
For i = 1 To UBound(arr_N, 1)
For j = arr_N(i, 1) To arr_N(i, 2)
Dic.Item(j) = i
Next

Next
End Sub
Sub dotim()
Dim i As Long, dcuoi As Long, j As Long, ii As Long
Dim arr_N()
Dim arr_D(), arr_Dotim()
Dim Dic As Object
Set Dic = CreateObject("scripting.dictionary")
Call thongke03(Dic, arr_Dotim)

dcuoi = Sheet1.Range("B10000").End(xlUp).Row
arr_N = Sheet1.Range("B2:B" & dcuoi)
ReDim arr_D(1 To UBound(arr_N, 1), 1 To 2)

For i = 1 To UBound(arr_N, 1)
If Dic.exists(arr_N(i, 1)) Then
j = Dic.Item(arr_N(i, 1))
arr_D(i, 1) = arr_Dotim(j, 3)
arr_D(i, 2) = arr_Dotim(j, 4)

End If
Next
Sheet1.Range("C2:D1000").Clear
Sheet1.Range("C2").Resize(UBound(arr_N, 1), 2) = arr_D
End Sub
Nhấp chuột vào đây để mở rộng...
Tôi đâu phải cùng ngành với bạn, bạn đưa file không có 1 ghi chú, không có kết quả mẫu muốn có v.v... làm sao biết đường mà mò.
Code viết quay mòng mòng mà biểu xem thì cũng như không, vì đâu có ra kết quả mà hình dung cách viết.
 
Upvote 0
Ba Tê đã viết:
Tôi đâu phải cùng ngành với bạn, bạn đưa file không có 1 ghi chú, không có kết quả mẫu muốn có v.v... làm sao biết đường mà mò.
Code viết quay mòng mòng mà biểu xem thì cũng như không, vì đâu có ra kết quả mà hình dung cách viết.
Nhấp chuột vào đây để mở rộng...

Dạ, con xin lỗi ạ. Con gửi Bác file đính kèm ạ, trong file con có mô tả ạ. Vùng màu xanh là kết quả ạ. Bác xem giúp con ạ. Con cảm ơn Bác.
 

File đính kèm

Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
17 18 19
Trả lời
369
Đọc
42K
zzklzz
Z
N
Tạo COM Add-In bằng Visual C++
Trả lời
0
Đọc
72
nguyendang95
N
vc_đi chơi
Cộng ngày từ sheet này sang sheet khác bị nhảy lung tung
Trả lời
7
Đọc
105
vc_đi chơi
vc_đi chơi
N
Giãn dòng trong excel
Trả lời
0
Đọc
52
nguyenichky
N
nguyenhoangtuananh9897
Hỏi về nơi tải danh sách xã huyện tỉnh chuẩn
2 3
Trả lời
40
Đọc
3K
Trần Văn Bình
T
Phan Thế Hiệp
Tìm ngày giờ kết thúc dự kiến (1 người xem)
    • Thích
    • Yêu thích
Trả lời
17
Đọc
656
Phan Thế Hiệp
Phan Thế Hiệp
GPE-Trợ Lý
[HCM] ĐĂNG KÝ THAM DỰ SINH NHẬT GIAIPHAPEXCEL LẦN THỨ 19 NGÀY 06/07/2025 (2 người xem)
    • Thích
    • Yêu thích
Trả lời
14
Đọc
1K
PhanTuHuong
PhanTuHuong
N
  • Question Question
Hỗ trợ tiếng việt trong macro
Trả lời
10
Đọc
324
ptm0412
ptm0412
T
Hướng dẫn kết hợp Drop List và Group PivotTable có điều kiện
Trả lời
7
Đọc
206
ptm0412
ptm0412
Limhachung
Lỗi không copy past excel
Trả lời
3
Đọc
84
vanle33
vanle33
V
Xử lý dữ liệu bị âm
Trả lời
9
Đọc
279
HieuCD
H
Nguyễn Duy Tuân
  • Dán lên cao
Phiên bản mới Add-in A-Tools AI v10 (2024) (5 người xem)
    • Thích
2 3
Trả lời
57
Đọc
7K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
K
  • Question Question
Viết code cho file lấy dữ liệu in -out từ bảng chấm công
Trả lời
0
Đọc
78
kimthoa89
K
N
gộp sheet có chứa hình ảnh
Trả lời
1
Đọc
95
thuytrangbp28
T
GPE-Trợ Lý
[ĐÀ NẴNG] ĐĂNG KÝ THAM DỰ SINH NHẬT GIAIPHAPEXCEL LẦN THỨ 19 NGÀY 13/07/2025
    • Thích
Trả lời
5
Đọc
277
tungnguyen_kt
tungnguyen_kt
OverAC
  • Dán lên cao
  • Suggestion Suggestion
Chúc mừng sinh nhật GiaiPhapExcel 19 tuổi và tặng ebook "Lập trình VBA phần cơ bản."
    • Thích
    • Yêu thích
Trả lời
3
Đọc
860
PhanTuHuong
PhanTuHuong
nguyenthidao2906
cách gộp nhiều file về 1 file trong google sheet
Trả lời
5
Đọc
994
nguyen thao1712
N
ongke0711
  • Question Question
Vấn đề HttpRequest "Get" trả về Response khác với Reponse thao tác trên trình duyệt
3 4 5
Trả lời
84
Đọc
8K
Huongthu.immanuel@gmail
H
T
Xin mọi người giúp tìm kết quả theo nhiều điều kiện lọc bằng Slicer.
Trả lời
4
Đọc
129
thanhsse
T
K
làm thế nào để in được hàng loạt phiếu lương của nhân viên trong 1 lệnh in
Trả lời
19
Đọc
11K
Hoàng Tuấn 868
H
Xem thêm…

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

Sinh nhật lần 19 GPE

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom