Xin giúp đỡ tính số tháng tham gia liên tục. (1 người xem)

Liên hệ QC

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

phananhvusv

Thành viên chính thức
Tham gia
28/3/17
Bài viết
72
Được thích
13
Nhờ các anh/chị giúp em với. Em có 1 file gồm 2 sheet, sheet 1 là danh sách tham gia BHYT, với mỗi người là 1 mã số BHXH duy nhất. Sheet 2 là dữ liệu tham gia BHYT theo mã số BHXH. 1 mã số BHXH có nhiều thẻ BHYT. Em muốn tính số tháng tham gia BHYT liên tục của từng người rồi điền vào sheet 1.
Điều kiện tính số tháng liên tục là:
- Thời gian tham gia nối tiếp nhau, hoặc có gián đoạn không quá 3 tháng thì tính là liên tục. (gián đoạn 3 tháng 1 ngày thì tính lại từ đầu). VD: mã số đầu tiên ở Sheet 2, do không tham gia năm 2015 (gián đoạn 12 tháng) nên chỉ được tính liên tục từ 1/1/2016 đến 31/12/2020 là 60 tháng. (và trong năm 2016 mặc dù có 2 thẻ nhưng vẫn chỉ tính 12 tháng)
- Phần thời gian gián đoạn từ 3 tháng trở xuống vẫn được tính là liên tục. VD: mã số A tham gia từ 1/1/2016 - 30/9/2016, sau đó tham gia tiếp từ 1/1/2017 - 31/12/2017, thì số tháng liên tục từ 1/1/2016 - 31/12/2017 là 24 tháng.

Anh/chị có cách nào giúp em với. Em cám ơn nhiều ạ.
 

File đính kèm

Bạn kiểm tra số liệu do macro đưa lại xem sao?

(Trước khi chạy macro cần xếp theo mã BHXH & cột bên phải liền kề với cột mã này
 

File đính kèm

Upvote 0
Nhờ các anh/chị giúp em với. Em có 1 file gồm 2 sheet, sheet 1 là danh sách tham gia BHYT, với mỗi người là 1 mã số BHXH duy nhất. Sheet 2 là dữ liệu tham gia BHYT theo mã số BHXH. 1 mã số BHXH có nhiều thẻ BHYT. Em muốn tính số tháng tham gia BHYT liên tục của từng người rồi điền vào sheet 1.
Điều kiện tính số tháng liên tục là:
- Thời gian tham gia nối tiếp nhau, hoặc có gián đoạn không quá 3 tháng thì tính là liên tục. (gián đoạn 3 tháng 1 ngày thì tính lại từ đầu). VD: mã số đầu tiên ở Sheet 2, do không tham gia năm 2015 (gián đoạn 12 tháng) nên chỉ được tính liên tục từ 1/1/2016 đến 31/12/2020 là 60 tháng. (và trong năm 2016 mặc dù có 2 thẻ nhưng vẫn chỉ tính 12 tháng)
- Phần thời gian gián đoạn từ 3 tháng trở xuống vẫn được tính là liên tục. VD: mã số A tham gia từ 1/1/2016 - 30/9/2016, sau đó tham gia tiếp từ 1/1/2017 - 31/12/2017, thì số tháng liên tục từ 1/1/2016 - 31/12/2017 là 24 tháng.

Anh/chị có cách nào giúp em với. Em cám ơn nhiều ạ.
Thử Code
Mã:
Sub SoThangLienTuc()
  Dim aData(), sArr(), Res(), MsBh$
  Dim sRow&, i&, fDay As Date, eDay As Date

  With Sheets("DATA")
    i = .Range("C" & Rows.Count).End(xlUp).Row
    sArr = .Range("A2:C" & i).Value
    .Range("A2:C" & i).Sort .Range("A2"), 1, .Range("B2"), , 1, Header:=xlNo
    aData = .Range("A2:C" & i + 1).Value
    .Range("A2:C" & i).Value = sArr
  End With
 
  With Sheets("STLT")
    sArr = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value
  End With
 
  With CreateObject("scripting.dictionary")
    sRow = UBound(aData)
    MsBh = aData(1, 1)
    fDay = aData(1, 2)
    eDay = aData(1, 3)
    For i = 1 To sRow - 1
      If DateAdd("m", 3, eDay) <= aData(i, 2) Then
        fDay = aData(i, 2)
        eDay = aData(i, 3)
      Else
        If eDay < aData(i, 3) Then eDay = aData(i, 3)
      End If
      If MsBh <> CStr(aData(i + 1, 1)) Then
        .Add MsBh, DateDiff("m", fDay, eDay) 'tinh tròn thang
        MsBh = aData(i + 1, 1)
        fDay = aData(i + 1, 2)
        eDay = aData(i + 1, 3)
      End If
    Next i
    
    sRow = UBound(sArr)
    ReDim Res(1 To sRow, 1 To 1)
    For i = 1 To sRow
      Res(i, 1) = .Item(CStr(sArr(i, 1)))
    Next i
  End With
 
  With Sheets("STLT")
    .Range("E2").Resize(sRow).Value = Res
  End With
End Sub
 
Upvote 0
Bạn kiểm tra số liệu do macro đưa lại xem sao?

(Trước khi chạy macro cần xếp theo mã BHXH & cột bên phải liền kề với cột mã này

Em chạy thử mà ko thấy nó làm gì hết anh ạ.

Thử Code
Mã:
Sub SoThangLienTuc()
  Dim aData(), sArr(), Res(), MsBh$
  Dim sRow&, i&, fDay As Date, eDay As Date

  With Sheets("DATA")
    i = .Range("C" & Rows.Count).End(xlUp).Row
    sArr = .Range("A2:C" & i).Value
    .Range("A2:C" & i).Sort .Range("A2"), 1, .Range("B2"), , 1, Header:=xlNo
    aData = .Range("A2:C" & i + 1).Value
    .Range("A2:C" & i).Value = sArr
  End With

  With Sheets("STLT")
    sArr = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value
  End With

  With CreateObject("scripting.dictionary")
    sRow = UBound(aData)
    MsBh = aData(1, 1)
    fDay = aData(1, 2)
    eDay = aData(1, 3)
    For i = 1 To sRow - 1
      If DateAdd("m", 3, eDay) <= aData(i, 2) Then
        fDay = aData(i, 2)
        eDay = aData(i, 3)
      Else
        If eDay < aData(i, 3) Then eDay = aData(i, 3)
      End If
      If MsBh <> CStr(aData(i + 1, 1)) Then
        .Add MsBh, DateDiff("m", fDay, eDay) 'tinh tròn thang
        MsBh = aData(i + 1, 1)
        fDay = aData(i + 1, 2)
        eDay = aData(i + 1, 3)
      End If
    Next i
   
    sRow = UBound(sArr)
    ReDim Res(1 To sRow, 1 To 1)
    For i = 1 To sRow
      Res(i, 1) = .Item(CStr(sArr(i, 1)))
    Next i
  End With

  With Sheets("STLT")
    .Range("E2").Resize(sRow).Value = Res
  End With
End Sub

Em chưa dò hết, nhưng xem vài trường hợp thì thấy chuẩn rồi á anh.
Em cám ơn 2 anh nhiều ạ.
 
Upvote 0

Anh cho em hỏi tí với. Em xem code mà không hiểu lắm.
VD trường hợp này: thẻ giá trị :
1/1/2015 - 31/12/2015
1/1/2016 - 31/12/2016
1/1/2018 - 31/12/2018

Nếu vòng lặp chạy qua thẻ 2016 thì nó hiểu là gián đoạn, nhưng chạy tiếp qua thẻ 2015 thì nó có tính thẻ 2015 vào không anh?
If eDay < aData(i, 3) Then eDay = aData(i, 3)
Cái dòng này có ý nghĩa gì trong code trên vậy anh?
 
Upvote 0
Anh cho em hỏi tí với. Em xem code mà không hiểu lắm.
VD trường hợp này: thẻ giá trị :
1/1/2015 - 31/12/2015
1/1/2016 - 31/12/2016
1/1/2018 - 31/12/2018

Nếu vòng lặp chạy qua thẻ 2016 thì nó hiểu là gián đoạn, nhưng chạy tiếp qua thẻ 2015 thì nó có tính thẻ 2015 vào không anh?
If eDay < aData(i, 3) Then eDay = aData(i, 3)
Cái dòng này có ý nghĩa gì trong code trên vậy anh?
Mình đã xếp thứ tự theo cột "B" ngày bắt đầu và vòng For chạy từ dòng đầu xuống dòng cuối. Theo ví dụ đầu tiên xét năm 2015 rồi tới 2016 cuối cùng 2018
Xét tới 2016 bị gián đoạn sẽ bỏ toàn bộ dữ liệu trước đó là 2015, tính lại fDay và eDay mới
"If eDay < aData(i, 3) Then eDay = aData(i, 3)"
Xét 2 ví dụ
1/Bình thường
1/1/2016 - 31/12/2016
1/1/2017 - 31/12/2017
Khi xét dòng đầu (2016)
fDay=1/1/2016
eDay =31/12/2016
Khi xét dòng 2 (2017)
eDay < aData(i, 3) thỏa nên eDay = aData(i, 3)=31/12/2017
2/Có thể xảy ra
1/1/2016 - 31/12/2018
1/1/2017 - 31/12/2017
Khi xét dòng đầu (2016)
fDay=1/1/2016
eDay =31/12/2018
Khi xét dòng 2 (2017)
eDay < aData(i, 3) Không thỏa nên eDay vẫn = 31/12/2018
 
Upvote 0
Mình đã xếp thứ tự theo cột "B" ngày bắt đầu và vòng For chạy từ dòng đầu xuống dòng cuối. Theo ví dụ đầu tiên xét năm 2015 rồi tới 2016 cuối cùng 2018
Xét tới 2016 bị gián đoạn sẽ bỏ toàn bộ dữ liệu trước đó là 2015, tính lại fDay và eDay mới
"If eDay < aData(i, 3) Then eDay = aData(i, 3)"
Xét 2 ví dụ
1/Bình thường
1/1/2016 - 31/12/2016
1/1/2017 - 31/12/2017
Khi xét dòng đầu (2016)
fDay=1/1/2016
eDay =31/12/2016
Khi xét dòng 2 (2017)
eDay < aData(i, 3) thỏa nên eDay = aData(i, 3)=31/12/2017
2/Có thể xảy ra
1/1/2016 - 31/12/2018
1/1/2017 - 31/12/2017
Khi xét dòng đầu (2016)
fDay=1/1/2016
eDay =31/12/2018
Khi xét dòng 2 (2017)
eDay < aData(i, 3) Không thỏa nên eDay vẫn = 31/12/2018

Ôi trời !!! Cái sort này lợi hại thiệt. Nếu không sort thì làm khó hơn hả anh?
À anh Hiếu ơi, cái file của em nó nhiều cột lắm, em tưởng lấy code của anh rồi sửa lại chút là được, mà sao sửa rồi chạy nó báo lỗi tùm lum. Anh xem thử giúp em với. Kết quả anh đưa ra cột Q ở sheets STLT nhe anh.
 

File đính kèm

Upvote 0
Ôi trời !!! Cái sort này lợi hại thiệt. Nếu không sort thì làm khó hơn hả anh?
À anh Hiếu ơi, cái file của em nó nhiều cột lắm, em tưởng lấy code của anh rồi sửa lại chút là được, mà sao sửa rồi chạy nó báo lỗi tùm lum. Anh xem thử giúp em với. Kết quả anh đưa ra cột Q ở sheets STLT nhe anh.
Thêm code chuyển ngày tháng
Mã:
Sub SoThangLienTuc()
  Dim aData(), sArr(), Res(), MsBh$
  Dim sRow&, i&, fDay As Date, eDay As Date

  With Sheets("DATA")
    i = .Range("C" & Rows.Count).End(xlUp).Row
    sArr = .Range("A2:AG" & i).Value
    Call ChuyenNgayThang 'Dang ngay thang sai, phai chuyen dang
    .Range("A2:AG" & i).Sort .Range("C2"), 1, .Range("F2"), , 1, Header:=xlNo
    aData = .Range("C2:G" & i + 1).Value
    .Range("A2:AG" & i).Value = sArr
  End With
 
  With Sheets("STLT")
    dongcuoi = .Range("D" & Rows.Count).End(xlUp).Row 'Bo lenh nay
    .Range("Q1") = "gia tri the cuoi"
    sArr = .Range("D2", .Range("D" & Rows.Count).End(xlUp)).Value
  End With
 
  With CreateObject("scripting.dictionary")
    sRow = UBound(aData)
    MsBh = aData(1, 1)
    fDay = aData(1, 4)
    eDay = aData(1, 5)
    For i = 1 To sRow - 1
      If DateAdd("m", 3, eDay) <= aData(i, 4) Then
        fDay = aData(i, 4)
        eDay = aData(i, 5)
      Else
        If eDay < aData(i, 5) Then eDay = aData(i, 5)
      End If
      If MsBh <> CStr(aData(i + 1, 1)) Then
        .Add MsBh, DateDiff("m", fDay, eDay) 'tinh tròn thang
        MsBh = aData(i + 1, 1)
        fDay = aData(i + 1, 4)
        eDay = aData(i + 1, 5)
      End If
    Next i
    
    sRow = UBound(sArr)
    ReDim Res(1 To sRow, 1 To 1)
    For i = 1 To sRow
      Res(i, 1) = .Item(CStr(sArr(i, 1)))
    Next i
  End With
 
  With Sheets("STLT")
    .Range("Q2").Resize(sRow).Value = Res
  End With
End Sub

Private Sub ChuyenNgayThang()
  Dim sArr(), eRow&, sRow&, i&, j&, tmp
  If Day(DateValue("1/5/2019")) = 1 Then Exit Sub
  With Sheets("DATA")
    eRow = .Range("G" & Rows.Count).End(xlUp).Row
    sArr = .Range("F2:G" & eRow).Value
  End With
  sRow = UBound(sArr)
  For i = 1 To sRow
    For j = 1 To 2
      tmp = sArr(i, j)
      If TypeName(tmp) = "Date" Then
        sArr(i, j) = DateSerial(Year(tmp), Day(tmp), Month(tmp))
      Else
        sArr(i, j) = DateValue(Mid(tmp, 7, 4) & Mid(tmp, 3, 4) & Mid(tmp, 1, 2))
      End If
    Next j
  Next i
  Sheets("DATA").Range("F2:G" & eRow) = sArr
End Sub
 
Upvote 0
Nó ra sai kết quả anh Hiếu ơi. Hình như lệnh sort bị sai thì phải, nó không chịu sort. Mà em thấy định dạng ngày tháng đâu có sai đâu nhỉ?
Có một số dòng ngày tháng dạng Text
Nhầm cột ngày, chỉnh lại
Mã:
Sub SoThangLienTuc()
  Dim aData(), sArr(), Res(), MsBh$
  Dim sRow&, i&, fDay As Date, eDay As Date

  With Sheets("DATA")
    i = .Range("C" & Rows.Count).End(xlUp).Row
    sArr = .Range("A2:AG" & i).Value
    Call ChuyenNgayThang 'Dang ngay thang sai, phai chuyen dang
    .Range("A2:AG" & i).Sort .Range("C2"), 1, .Range("F2"), , 1, Header:=xlNo
    aData = .Range("C2:G" & i + 1).Value
    .Range("A2:AG" & i).Value = sArr
  End With
 
  With Sheets("STLT")
   sArr = .Range("D2", .Range("D" & Rows.Count).End(xlUp)).Value
  End With
 
  With CreateObject("scripting.dictionary")
    sRow = UBound(aData)
    MsBh = aData(1, 1)
    fDay = aData(1, 4)
    eDay = aData(1, 5)
    For i = 1 To sRow - 1
      If DateAdd("m", 3, eDay) <= aData(i, 4) Then
        fDay = aData(i, 4)
        eDay = aData(i, 5)
      Else
        If eDay < aData(i, 5) Then eDay = aData(i, 5)
      End If
      If MsBh <> CStr(aData(i + 1, 1)) Then
        .Add MsBh, DateDiff("m", fDay, eDay) 'tinh tròn thang
        MsBh = aData(i + 1, 1)
        fDay = aData(i + 1, 4)
        eDay = aData(i + 1, 5)
      End If
    Next i
    
    sRow = UBound(sArr)
    ReDim Res(1 To sRow, 1 To 1)
    For i = 1 To sRow
      Res(i, 1) = .Item(CStr(sArr(i, 1)))
    Next i
  End With
 
  With Sheets("STLT")
    .Range("Q2").Resize(sRow).Value = Res
  End With
End Sub

Private Sub ChuyenNgayThang()
  Dim sArr(), eRow&, sRow&, i&, j&, tmp, VNdate As Boolean
 
  With Sheets("DATA")
    eRow = .Range("G" & Rows.Count).End(xlUp).Row
    sArr = .Range("F2:G" & eRow).Value
  End With
  sRow = UBound(sArr)
  If Day(DateValue("1/5/2019")) = 1 Then VNdate = True
  For i = 1 To sRow
    For j = 1 To 2
      tmp = sArr(i, j)
      If TypeName(tmp) = "String" Then
        If VNdate = False Then
          sArr(i, j) = DateValue(Mid(tmp, 7, 4) & Mid(tmp, 3, 4) & Mid(tmp, 1, 2))
        Else
          sArr(i, j) = DateValue(tmp)
        End If
      End If
    Next j
  Next i
  Sheets("DATA").Range("F2:G" & eRow) = sArr
End Sub
 
Upvote 0
Có một số dòng ngày tháng dạng Text
Nhầm cột ngày, chỉnh lại

Anh Hiếu ơi, cái cột ngày tháng sau khi chỉnh lại nó đảo ngày tháng rồi, VD 01/10/2015 thì thành 10/01/2015
Với cái cột Mã số BHXH chuyển sang dạng số thì nhiều trường hợp bị mất số 0. VD 0113146392.
Cái datedif nó tính số tháng sao vậy anh? VD 1/1/2015 - 31/12/2015 thì có đúng là 12 tháng ko anh? Tại vì em dùng hàm datedif của excel thì nó tính là 11 tháng à, em phải cộng thêm 1 ngày vô cột cuối để nó tính là 12 tháng cho đúng á.
 
Upvote 0
Anh Hiếu ơi, cái cột ngày tháng sau khi chỉnh lại nó đảo ngày tháng rồi, VD 01/10/2015 thì thành 10/01/2015
Với cái cột Mã số BHXH chuyển sang dạng số thì nhiều trường hợp bị mất số 0. VD 0113146392.
Cái datedif nó tính số tháng sao vậy anh? VD 1/1/2015 - 31/12/2015 thì có đúng là 12 tháng ko anh? Tại vì em dùng hàm datedif của excel thì nó tính là 11 tháng à, em phải cộng thêm 1 ngày vô cột cuối để nó tính là 12 tháng cho đúng á.
"đảo ngày tháng rồi, VD 01/10/2015 thì thành 10/01/2015 " ở cột nào dòng nào?
"cột Mã số BHXH chuyển sang dạng số thì nhiều trường hợp bị mất số 0. VD 0113146392. " Mình đâu có đụng gì cột nầy
Chỉnh lại lệnh
Mã:
Sub SoThangLienTuc()
  Dim aData(), sArr(), Res(), MsBh$, tmp$
  Dim sRow&, i&, fDay As Date, eDay As Date, SoThang&

  With Sheets("DATA")
    i = .Range("C" & Rows.Count).End(xlUp).Row
    sArr = .Range("A2:AG" & i).Value
    Call ChuyenNgayThang 'Dang ngay thang sai, phai chuyen dang
    .Range("A2:AG" & i).Sort .Range("C2"), 1, .Range("F2"), , 1, Header:=xlNo
    aData = .Range("C2:G" & i + 1).Value
    .Range("A2:AG" & i).Value = sArr
  End With
 
  With Sheets("STLT")
   sArr = .Range("D2", .Range("D" & Rows.Count).End(xlUp)).Value
  End With
 
  With CreateObject("scripting.dictionary")
    sRow = UBound(aData)
    MsBh = Format(aData(1, 1), "0000000000") 'Ma So co 10 ky tu
    fDay = aData(1, 4)
    eDay = aData(1, 5)
    For i = 1 To sRow - 1
      If DateAdd("m", 3, eDay) <= aData(i, 4) Then
        fDay = aData(i, 4)
        eDay = aData(i, 5)
      Else
        If eDay < aData(i, 5) Then eDay = aData(i, 5)
      End If
      tmp = Format(aData(i + 1, 1), "0000000000")
      If MsBh <> tmp Then
        SoThang = DateDiff("m", fDay, eDay + 1)
        If DateAdd("m", SoThang, fDay) - 1 > eDay Then SoThang = SoThang - 1
        .Add MsBh, SoThang
        MsBh = tmp
        fDay = aData(i + 1, 4)
        eDay = aData(i + 1, 5)
      End If
    Next i
    
    sRow = UBound(sArr)
    ReDim Res(1 To sRow, 1 To 1)
    For i = 1 To sRow
      Res(i, 1) = .Item(Format(sArr(i, 1), "0000000000"))
    Next i
  End With
 
  With Sheets("STLT")
    .Range("Q2").Resize(sRow).Value = Res
  End With
End Sub
 
Upvote 0
Ngay dòng đầu tiên trong sheet data, lúc copy vô là ngày 01/08/2019, chạy code xong thì thấy bị đảo lại thành 08/01/2019 nên số liệu ra bị sai á anh. Với lại em không thấy nó sort được theo cột "Từ ngày" anh ơi.
 

File đính kèm

Upvote 0
Ngay dòng đầu tiên trong sheet data, lúc copy vô là ngày 01/08/2019, chạy code xong thì thấy bị đảo lại thành 08/01/2019 nên số liệu ra bị sai á anh. Với lại em không thấy nó sort được theo cột "Từ ngày" anh ơi.
Chỉnh lại code
Mã:
Sub SoThangLienTuc()
  Dim aData(), sArr(), Res(), MsBh$, tmp$
  Dim sRow&, i&, fDay As Date, eDay As Date, SoThang&

  With Sheets("DATA")
    Call CreateArr(aData)
  End With
  With Sheets("STLT")
   sArr = .Range("D2", .Range("D" & Rows.Count).End(xlUp)).Value
  End With
 
  With CreateObject("scripting.dictionary")
    sRow = UBound(aData)
    MsBh = Format(aData(1, 1), "0000000000") 'Ma So co 10 ky tu
    fDay = aData(1, 4)
    eDay = aData(1, 5)
    For i = 1 To sRow - 1
      If DateAdd("m", 3, eDay) <= aData(i, 4) Then
        fDay = aData(i, 4)
        eDay = aData(i, 5)
      Else
        If eDay < aData(i, 5) Then eDay = aData(i, 5)
      End If
      tmp = Format(aData(i + 1, 1), "0000000000")
      If MsBh <> tmp Then
        SoThang = DateDiff("m", fDay, eDay + 1)
        If DateAdd("m", SoThang, fDay) - 1 > eDay Then SoThang = SoThang - 1
        .Add MsBh, SoThang
        MsBh = tmp
        fDay = aData(i + 1, 4)
        eDay = aData(i + 1, 5)
      End If
    Next i
    
    sRow = UBound(sArr)
    ReDim Res(1 To sRow, 1 To 1)
    For i = 1 To sRow
      Res(i, 1) = .Item(Format(sArr(i, 1), "0000000000"))
    Next i
  End With
 
  With Sheets("STLT")
    .Range("Q2").Resize(sRow).Value = Res
  End With
End Sub

Private Sub CreateArr(ByRef aData)
  Dim sArr(), Arr() As String, eRow&, sRow&, sCol&, i&, j&, tmp, VNdate As Boolean
 
  With Sheets("DATA")
    eRow = .Range("G" & Rows.Count).End(xlUp).Row
    sArr = .Range("C2:G" & eRow).Value
    sRow = UBound(sArr): sCol = UBound(sArr, 2)
    ReDim Arr(1 To sRow, 1 To sCol)
    For i = 1 To sRow
      For j = 1 To sCol
        Arr(i, j) = CStr(sArr(i, j))
      Next j
    Next i
    sArr = .Range("F2:G" & eRow).Value
    If Day(DateValue("1/5/2019")) = 1 Then VNdate = True
    For i = 1 To sRow
      For j = 1 To 2
        tmp = sArr(i, j)
        If TypeName(tmp) = "String" Then
          If VNdate = False Then
            sArr(i, j) = DateValue(Mid(tmp, 7, 4) & Mid(tmp, 3, 4) & Mid(tmp, 1, 2))
          Else
            sArr(i, j) = DateValue(tmp)
          End If
        End If
      Next j
    Next i
    .Range("F2:G" & eRow) = sArr
    .Range("C2:G" & eRow).Sort .Range("C2"), 1, .Range("F2"), , 1, Header:=xlNo
    aData = .Range("C2:G" & eRow).Value
    .Range("C2:G" & eRow) = Arr
  End With
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Em cám ơn anh nhiều ạ, mặc dù em ko thấy nó sort theo cột F, nhưng kết quả vẫn đúng ạ.
Không biết file của bạn còn làm tiếp gì không, sao khi xử lý phải trả về nguyên trạng, xóa mọi dấu vết có thể bị khép tội xâm phạm bất hợp pháp
Mở code, click chuột vào sub và bấm phím chức năng F8 rồi bấm F8 ... nhìn trên sheet sẽ thấy vận hành của code
 
Upvote 0
Không biết file của bạn còn làm tiếp gì không, sao khi xử lý phải trả về nguyên trạng, xóa mọi dấu vết có thể bị khép tội xâm phạm bất hợp pháp
Mở code, click chuột vào sub và bấm phím chức năng F8 rồi bấm F8 ... nhìn trên sheet sẽ thấy vận hành của code
Em không ngờ là có thể làm được vậy luôn. Theo em hiểu, cái code của anh là đưa dữ liệu vào mảng, rồi xử lý trên mảng, chứ không ảnh hưởng gì đến file phải ko anh? Em đã học 1 khóa cơ bản VBA + 2 quyển sách của diễn đàn, mà xem code của anh vẫn chưa hiểu hết được. Em cần phải học gì thêm nữa anh?
 
Upvote 0
Em không ngờ là có thể làm được vậy luôn. Theo em hiểu, cái code của anh là đưa dữ liệu vào mảng, rồi xử lý trên mảng, chứ không ảnh hưởng gì đến file phải ko anh? Em đã học 1 khóa cơ bản VBA + 2 quyển sách của diễn đàn, mà xem code của anh vẫn chưa hiểu hết được. Em cần phải học gì thêm nữa anh?
Viết code nhiều sẽ có kinh nghiệm, mình không sách cũng không được học bài bản, chỉ nhờ lên diễn đàn viết code lung tung, sai tá lã... được các bạn hổ trợ nên dần dần hoàn thiện
Xem ghi chú trong sub sẽ hiểu cách vận hành
Mã:
Private Sub CreateArr(ByRef aData)
  Dim sArr() As Variant, Arr() As String, eRow&, sRow&, sCol&, i&, j&, tmp, VNdate As Boolean
  With Sheets("DATA")
    eRow = .Range("G" & Rows.Count).End(xlUp).Row
    sArr = .Range("C2:G" & eRow).Value 'Gán du lieu vao mang
    sRow = UBound(sArr): sCol = UBound(sArr, 2)
    ReDim Arr(1 To sRow, 1 To sCol) 'Mang du lieu goc dang String theo dinh dang du lieu
'Chuyen mang sArr dang Variant sang mang Arr dang String
    For i = 1 To sRow
      For j = 1 To sCol
        Arr(i, j) = CStr(sArr(i, j))
      Next j
    Next i
'Chuyen Ngay thang theo dang Sting thanh dang Date, bang mang sArr
    sArr = .Range("F2:G" & eRow).Value
    If Day(DateValue("1/5/2019")) = 1 Then VNdate = True
    For i = 1 To sRow
      For j = 1 To 2
        tmp = sArr(i, j)
        If TypeName(tmp) = "String" Then
          If VNdate = False Then
            sArr(i, j) = DateValue(Mid(tmp, 7, 4) & Mid(tmp, 3, 4) & Mid(tmp, 1, 2))
          Else
            sArr(i, j) = DateValue(tmp)
          End If
        End If
      Next j
    Next i
'Gan ngay thang vào sheet
    .Range("F2:G" & eRow) = sArr
'Sort du lieu trong sheet
    .Range("C2:G" & eRow).Sort .Range("C2"), 1, .Range("F2"), , 1, Header:=xlNo
'Lay ket qua sort
    aData = .Range("C2:G" & eRow).Value
'Tra ve gia tri goc cua file
    .Range("C2:G" & eRow) = Arr
  End With
End Sub
 
Upvote 0
Viết code nhiều sẽ có kinh nghiệm, mình không sách cũng không được học bài bản, chỉ nhờ lên diễn đàn viết code lung tung, sai tá lã... được các bạn hổ trợ nên dần dần hoàn thiện
Xem ghi chú trong sub sẽ hiểu cách vận hành

Cái vụ định dạng ngày tháng đúng là căng thiệt.
If Day(DateValue("1/5/2019")) = 1 Then VNdate = True
Cái này có ý nghĩa gì anh nhỉ? Biến VNdate chỉ có True và False, theo câu trên thì mình xác định là đúng, còn khi nào thì nó False anh nhỉ?
 
Upvote 0
Em không ngờ là có thể làm được vậy luôn. Theo em hiểu, cái code của anh là đưa dữ liệu vào mảng, rồi xử lý trên mảng, chứ không ảnh hưởng gì đến file phải ko anh? Em đã học 1 khóa cơ bản VBA + 2 quyển sách của diễn đàn, mà xem code của anh vẫn chưa hiểu hết được. Em cần phải học gì thêm nữa anh?
Tôi làm việc với code mấy chục năm rồi, mà xem code ở diễn đàn này cũng chưa chắc hiểu hết được.
Muốn hiểu code ở đây thì học theo trường phái code ở đây. Không có cách nào khác.

Chú phần xanh: học 1 khoá cơ bản và 2 quyển sách mà viết diễn giải vấn đề như bài #1 thì có lẽ cái khoá cơ bản kia không hề dạy bạn cách diễn giải vấn đề theo đúng trình tự lô gic.
Nguyên tắc lập trình là nếu diễn giải vấn đề đúng trình tự và lô gic thì coi như đã xong phân nửa. Phần còn lại chỉ là dịch từ diễn giải trên ra code thôi.
2 quyển sách kia có bao nhiêu bài tập? Bạn đã làm hết các bài tập ấy chưa?
Hòi xưa tôi học chỉ có 1 quyển sách nhỏ rí. Nhưng tôi làm không sót một bài tập nào. Mà lúc ấy máy tính còn chưa có mấy cái IDE với chức năng copy/paste-find/replace-debug mạnh như bây giờ. Mỗi bài tập tôi gõ code lại từ đầu. (vả lại lúc mới học đâu có hiểu cái mẹo để giành code vào thư viện)
 
Upvote 0
Cái vụ định dạng ngày tháng đúng là căng thiệt.
If Day(DateValue("1/5/2019")) = 1 Then VNdate = True
Cái này có ý nghĩa gì anh nhỉ? Biến VNdate chỉ có True và False, theo câu trên thì mình xác định là đúng, còn khi nào thì nó False anh nhỉ?
Biến luận lý VNdate là dạng ngày tháng của hệ thống (khai báo trong control panel) kiểu Việt nam
VNdate = true: Máy tính có dạng ngày tháng của hệ thống theo kiểu Việt nam
VNdate = false: Máy tính có dạng ngày tháng của hệ thống theo kiểu Mỹ
 
Upvote 0
Biến luận lý VNdate là dạng ngày tháng của hệ thống (khai báo trong control panel) kiểu Việt nam
VNdate = true: Máy tính có dạng ngày tháng của hệ thống theo kiểu Việt nam
VNdate = false: Máy tính có dạng ngày tháng của hệ thống theo kiểu Mỹ

Anh Hiếu ơi, anh xem giúp em code này với.
Mã:
Sub dictMadoituong()
Dim dongcuoi As Long
Dim vungchon() As Variant
Dim khoa As String
Dim i As Long
Dim dic As Object
Set dic = CreateObject("scripting.dictionary")
With Sheets("DATA")
dongcuoi = .Cells(.Rows.Count, "N").End(xlUp).Row
vungchon = Range("N2:N" & dongcuoi)
For i = 1 To dongcuoi - 1
    khoa = vungchon(i, 1)
    If Not dic.exists(khoa) Then
    dic.Add vungchon(i, 1), 1
    Else
    dic.Item(khoa) = dic.Item(khoa) + 1
    End If
Next i
End With
With Sheets("Sheet1")
Range("a14:a" & dic.Count + 13) = Application.Transpose(dic.keys)
Range("b14:b" & dic.Count + 13) = Application.Transpose(dic.items)
End With
End Sub

Tại sao em dùng With sheets thì nó không gán dic.keys và dic.items vào range được anh nhỉ?
Em thử dùng sheets("sheet1").select thì nếu đang ở sheet khác thì ra kết quả, còn đang ở sheet1 thì ko ra.
Còn vấn đề nữa là em dùng pivottable rồi ghi macro lại, sau đó thử thì máy em chạy ok, chuyển qua máy khác thì bị báo lỗi Run time '05'. Vào debug thì tô vàng chỗ code Pivot này:
Mã:
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "DATA!R1C14:R1048576C15", Version:=xlPivotTableVersion15).CreatePivotTable _
        TableDestination:="Sheet1!R14C1", TableName:="DemMaDoiTuong", DefaultVersion _
        :=xlPivotTableVersion15
Anh xem giúp em với, em cám ơn ạ.
 

File đính kèm

Upvote 0
Anh Hiếu ơi, anh xem giúp em code này với.
Mã:
Sub dictMadoituong()
Dim dongcuoi As Long
Dim vungchon() As Variant
Dim khoa As String
Dim i As Long
Dim dic As Object
Set dic = CreateObject("scripting.dictionary")
With Sheets("DATA")
dongcuoi = .Cells(.Rows.Count, "N").End(xlUp).Row
vungchon = Range("N2:N" & dongcuoi)
For i = 1 To dongcuoi - 1
    khoa = vungchon(i, 1)
    If Not dic.exists(khoa) Then
    dic.Add vungchon(i, 1), 1
    Else
    dic.Item(khoa) = dic.Item(khoa) + 1
    End If
Next i
End With
With Sheets("Sheet1")
Range("a14:a" & dic.Count + 13) = Application.Transpose(dic.keys)
Range("b14:b" & dic.Count + 13) = Application.Transpose(dic.items)
End With
End Sub

Tại sao em dùng With sheets thì nó không gán dic.keys và dic.items vào range được anh nhỉ?
Em thử dùng sheets("sheet1").select thì nếu đang ở sheet khác thì ra kết quả, còn đang ở sheet1 thì ko ra.
Còn vấn đề nữa là em dùng pivottable rồi ghi macro lại, sau đó thử thì máy em chạy ok, chuyển qua máy khác thì bị báo lỗi Run time '05'. Vào debug thì tô vàng chỗ code Pivot này:
Mã:
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "DATA!R1C14:R1048576C15", Version:=xlPivotTableVersion15).CreatePivotTable _
        TableDestination:="Sheet1!R14C1", TableName:="DemMaDoiTuong", DefaultVersion _
        :=xlPivotTableVersion15
Anh xem giúp em với, em cám ơn ạ.
Thiếu dấu "." trước Cells và Range nên nhận diện sai Sheet
Mã:
Sub dictMadoituong()
Dim dongcuoi As Long
Dim vungchon() As Variant
Dim khoa As String
Dim i As Long
Dim dic As Object
Set dic = CreateObject("scripting.dictionary")
With Sheets("DATA")
  dongcuoi = .Cells(.Rows.Count, "N").End(xlUp).Row
  vungchon = .Range("N2:N" & dongcuoi).Value
  For i = 1 To dongcuoi - 1
    khoa = vungchon(i, 1)
    If Not dic.exists(khoa) Then
      dic.Add vungchon(i, 1), 1
    Else
      dic.Item(khoa) = dic.Item(khoa) + 1
    End If
  Next i
End With

With Sheets("Sheet1")
  .Range("a14:a" & dic.Count + 13) = Application.Transpose(dic.keys)
  .Range("b14:b" & dic.Count + 13) = Application.Transpose(dic.items)
End With
End Sub
Vấn đề thứ 2 có thể là do "xlPivotTableVersion15", thử thu Macro trên máy bị lổi và so sánh lệnh
 
Upvote 0
Em cũng nghĩ vậy. Vì có vài máy dùng được, còn khác phiên bản Excel thì lỗi. Vậy cách nào sửa được lỗi này vậy anh? nếu em vẫn dùng PivotTable?
Mình không có nhiều Version office nên không thử được, PivotTable nên làm thủ công, hạn chế dùng code VBA
 
Upvote 0
Mình không có nhiều Version office nên không thử được, PivotTable nên làm thủ công, hạn chế dùng code VBA
Anh Hiếu xem giúp em code dưới bị báo lỗi sothang chỗ .Countif(sothang, ">59")
Em muốn dùng mảng 1 chiều để lưu kết quả tạm thời, sau đó tính countif trên mảng đó, mà em không hiểu tại sao nó báo lỗi nhỉ?

Mã:
Sub testsothang()
Dim sothang() As Long
Dim tungay As Variant
Dim dongcuoi As Long
Dim ketqua As Variant
Dim i As Long

With Sheets("DATA")
dongcuoi = .Cells(.Rows.Count, "W").End(xlUp).Row
tungay = .Range("w2:w" & dongcuoi).Value
For i = 1 To dongcuoi - 1
ReDim sothang(1 To dongcuoi - 1, 1)
sothang(i, 1) = DateDiff("m", tungay(i, 1), Date)
Next i
End With
Sheets("sheet1").Range("C6").Value = WorksheetFunction.CountIf(sothang, ">59")

End Sub
 
Upvote 0
Anh Hiếu xem giúp em code dưới bị báo lỗi sothang chỗ .Countif(sothang, ">59")
Em muốn dùng mảng 1 chiều để lưu kết quả tạm thời, sau đó tính countif trên mảng đó, mà em không hiểu tại sao nó báo lỗi nhỉ?
Sheets("sheet1").Range("C6").Value = WorksheetFunction.CountIf(sothang, ">59")
Không được hỏi nên hơi vô duyên.

Tham số đầu tiên của WorksheetFunction.CountIf phải là đối tượng Range, tức là một vùng trên sheet. Mảng sothang thì dĩ nhiên không phải là đối tượng Range rồi.
-------------
Cái sai cơ bản (sau khi học 1 khoá cơ bản và 2 quyển sách) là Redim đặt trong vòng lặp FOR. Không chỉ tốn điện nước mà do Redim (không phải Redim Preserve) trong vòng lặp nên cuối cùng mảng sothang chỉ có dữ liệu ở dòng cuối cùng, do thực hiện vòng lặp cuối cùng, còn các dòng khác có giá trị 0. Tức các giá trị tính được trước đó do FOR đổ mồ hôi nước mắt, lao động cật lực, sẽ bị xóa hết. Tất nhiên thêm Preserve sau Redim (trong vòng FOR) cũng không được vì không thay đổi được số dòng. Chỉ có thể thay đổi được số cột.

Redim làm 1 lần trước vòng FOR thôi.
 
Upvote 0
Không được hỏi nên hơi vô duyên.

Tham số đầu tiên của WorksheetFunction.CountIf phải là đối tượng Range, tức là một vùng trên sheet. Mảng sothang thì dĩ nhiên không phải là đối tượng Range rồi.
-------------
Cái sai cơ bản (sau khi học 1 khoá cơ bản và 2 quyển sách) là Redim đặt trong vòng lặp FOR. Không chỉ tốn điện nước mà do Redim (không phải Redim Preserve) trong vòng lặp nên cuối cùng mảng sothang chỉ có dữ liệu ở dòng cuối cùng, do thực hiện vòng lặp cuối cùng, còn các dòng khác có giá trị 0. Tức các giá trị tính được trước đó do FOR đổ mồ hôi nước mắt, lao động cật lực, sẽ bị xóa hết. Tất nhiên thêm Preserve sau Redim (trong vòng FOR) cũng không được vì không thay đổi được số dòng. Chỉ có thể thay đổi được số cột.

Redim làm 1 lần trước vòng FOR thôi.
Ha ha, không vô duyên đâu ạ. :)
Dạ, cái vụ redim là do lúc sửa code em copy paste nhầm mà không hay, chứ ko phải em viết vậy. Cám ơn anh đã nhắc nhở, em đã sửa rồi ạ.
Anh giúp em cái vụ Countif với ạ, nếu em muốn đếm có điều kiện từ cái mảng đó (dữ liệu lớn quá nên em không muốn gán vào sheet sẽ gây chậm) thì có cách nào khác không ạ?
 
Upvote 0
Ha ha, không vô duyên đâu ạ. :)
Dạ, cái vụ redim là do lúc sửa code em copy paste nhầm mà không hay, chứ ko phải em viết vậy. Cám ơn anh đã nhắc nhở, em đã sửa rồi ạ.
Anh giúp em cái vụ Countif với ạ, nếu em muốn đếm có điều kiện từ cái mảng đó (dữ liệu lớn quá nên em không muốn gán vào sheet sẽ gây chậm) thì có cách nào khác không ạ?
Code ví dụ
Mã:
Sub testsothang()
Dim tungay()
Dim dongcuoi As Long, sothang As Long, ketqua As Long, i As Long
    With ThisWorkbook.Worksheets("DATA")
        dongcuoi = .Cells(Rows.Count, "W").End(xlUp).Row
        If dongcuoi < 2 Then Exit Sub
    '    lay du  dong
        tungay = .Range("w2:w" & dongcuoi + 1).Value
    End With
'    khong xet dong lay du
    For i = 1 To UBound(tungay) - 1
        sothang = DateDiff("m", tungay(i, 1), Date)
        If sothang > 59 Then ketqua = ketqua + 1
    Next i
    Sheets("sheet1").Range("C6").Value = ketqua
End Sub

Điều kiện: dữ liệu cột W phải là ngày tháng theo cách hiểu của Excel. Hiên thời trong cột W không là ngày tháng chuẩn, chỉ là giả bộ ngày tháng. Thử như sau
nhập công thức ở đâu đó
Mã:
=W2+1
Trên máy tôi kết quả là #VALUE!
 
Upvote 0
Code ví dụ
Mã:
Sub testsothang()
Dim tungay()
Dim dongcuoi As Long, sothang As Long, ketqua As Long, i As Long
    With ThisWorkbook.Worksheets("DATA")
        dongcuoi = .Cells(Rows.Count, "W").End(xlUp).Row
        If dongcuoi < 2 Then Exit Sub
    '    lay du  dong
        tungay = .Range("w2:w" & dongcuoi + 1).Value
    End With
'    khong xet dong lay du
    For i = 1 To UBound(tungay) - 1
        sothang = DateDiff("m", tungay(i, 1), Date)
        If sothang > 59 Then ketqua = ketqua + 1
    Next i
    Sheets("sheet1").Range("C6").Value = ketqua
End Sub

Điều kiện: dữ liệu cột W phải là ngày tháng theo cách hiểu của Excel. Hiên thời trong cột W không là ngày tháng chuẩn, chỉ là giả bộ ngày tháng. Thử như sau
nhập công thức ở đâu đó
Mã:
=W2+1
Trên máy tôi kết quả là #VALUE!
Code phía trên của em đâu có dư dòng nhỉ?
Em thử ?W2+1 =1
Có 1 điều em thấy lạ, hàm Datediff trong VBA và hàm Datedif của Excel không ra giống kết quả.
Em thử Datediff ("m", "12/31/2019","01/01/2020") thì nó =1, trong khi dùng Datedif bên Excel sẽ =0. Kết quả em cần là phải tính tròn tháng, ví dụ ngày 1/1/2019 đến 31/1/2019 phải là 1 tháng, còn 1/1/2019 đến 30/1/2019 thì =0. Datedif của Excel thì em phải cộng thêm 1 ngày để nó tính đúng như vậy, vì 1/1/2019 đến 1/2/2019 nó mới tính là 1 tháng.
 
Upvote 0
Code phía trên của em đâu có dư dòng nhỉ?
Em thử ?W2+1 =1
Có 1 điều em thấy lạ, hàm Datediff trong VBA và hàm Datedif của Excel không ra giống kết quả.
Em thử Datediff ("m", "12/31/2019","01/01/2020") thì nó =1, trong khi dùng Datedif bên Excel sẽ =0. Kết quả em cần là phải tính tròn tháng, ví dụ ngày 1/1/2019 đến 31/1/2019 phải là 1 tháng, còn 1/1/2019 đến 30/1/2019 thì =0. Datedif của Excel thì em phải cộng thêm 1 ngày để nó tính đúng như vậy, vì 1/1/2019 đến 1/2/2019 nó mới tính là 1 tháng.
Tôi chỉ đọc 1 bài của bạn và sửa cho hết lỗi. Còn chuyện bạn muốn tính gì thì do tôi không đọc các bài khác trong chủ đề nên không biết.

Nếu bạn muốn tính tròn tháng thì cũng tùy thế nào là tròn tháng theo cách hiểu của bạn.
Bạn cho vd. ngày là 01. Tôi muốn biết cái từ ngày > 1

Vd. ngày 05/12/2019 đến 05/01/2020 theo bạn đã tròn tháng chưa? Theo tôi thì là tròn 1 tháng.
Tức theo tôi từ 05/12/2019 đến tận 04/02/2020 đều chỉ tròn 1 tháng. Từ 05/12/2019 đến ít nhất là 05/02/2020 mới tròn 2 tháng.

Nếu bạn tính tròn tháng như tôi thì sửa trong code của tôi dòng thích hợp thành
Mã:
sothang = DateDiff("m", tungay(i, 1), Date) + (Day(tungay(i, 1)) > Day(Date))

Dấu + chứ không là dấu - vì TRUE trong VBA được ép thành -1

hoặc là
Mã:
sothang = DateDiff("m", tungay(i, 1), Date)
If Day(tungay(i, 1)) > Day(Date) Then sothang = sothang - 1

Tất nhiên dữ liệu trong cột W phải là ngày tháng xịn nhé.
 
Upvote 0
Tôi chỉ đọc 1 bài của bạn và sửa cho hết lỗi. Còn chuyện bạn muốn tính gì thì do tôi không đọc các bài khác trong chủ đề nên không biết.

Nếu bạn muốn tính tròn tháng thì cũng tùy thế nào là tròn tháng theo cách hiểu của bạn.
Bạn cho vd. ngày là 01. Tôi muốn biết cái từ ngày > 1

Vd. ngày 05/12/2019 đến 05/01/2020 theo bạn đã tròn tháng chưa? Theo tôi thì là tròn 1 tháng.
Tức theo tôi từ 05/12/2019 đến tận 04/02/2020 đều chỉ tròn 1 tháng. Từ 05/12/2019 đến ít nhất là 05/02/2020 mới tròn 2 tháng.

Nếu bạn tính tròn tháng như tôi thì sửa trong code của tôi dòng thích hợp thành
Mã:
sothang = DateDiff("m", tungay(i, 1), Date) + (Day(tungay(i, 1)) > Day(Date))

Dấu + chứ không là dấu - vì TRUE trong VBA được ép thành -1

hoặc là
Mã:
sothang = DateDiff("m", tungay(i, 1), Date)
If Day(tungay(i, 1)) > Day(Date) Then sothang = sothang - 1

Tất nhiên dữ liệu trong cột W phải là ngày tháng xịn nhé.
Em thử ?day(range("W2")) = 5
?month(range("W3")) = 4
?date = 05/01/2020
Vậy là xịn rồi phải không anh?
Em cám ơn anh nhiều ạ.
 
Upvote 0

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

Back
Top Bottom