Xin thuật giải đếm số lần đổi màu, đổi mã (1 người xem)

[boma]

Xin bạn nào biết, hướng dẫn thuật giải hay code vba để đếm số lần đổi màu, đổi mã theo kiểu mình đã trình bày trong file excel. Mình đã tìm khắp diễn đàn mà chưa thấy kiểu đếm nào "éo le" như của mình.

 

[leonguyenz]

Xin bạn nào biết, hướng dẫn thuật giải hay code vba để đếm số lần đổi màu, đổi mã theo kiểu mình đã trình bày trong file excel. Mình đã tìm khắp diễn đàn mà chưa thấy kiểu đếm nào "éo le" như của mình.

Giải pháp: dùng vòng lặp, giá trị sau khác với giá trị trước thì đếm.

 

[boma]

Giải pháp: dùng vòng lặp, giá trị sau khác với giá trị trước thì đếm.

1/ Giả sử mình đã tách được những màu máy H1 chạy được trong tháng 5 ra mảng arr1 như file kèm theo . Mảng này có 16 phần tử có giá trị, còn 3 phần tử cuối thì rỗng, vậy làm sao để resize nó lại cho vừa với số phần tử có giá trị ?

2/ Mình sẽ tiến hành đếm trên mảng này như thế nào khi mảng này vẫn còn nằm trong bộ nhớ máy ? Ngữ pháp vba mình biết cũng có hạn nên ko tài nào code được chỗ này. (code còn đang nháp nên xin thông cảm nếu lộn xộn)

 

[thuyyeu99]

File bạn mình có thấy cái cột nào rỗng đâu nhỉ

 

[ThangCuAnh]

Khó nhỉ, mình vẫn chưa nghĩ ra thuật toán.

 

[ongke0711]

Nếu không dùng vòng lặp, và mình dùng câu lệnh truy vấn SQL thông qua ADODB để nó ra 2 cột phụ phục vụ việc đếm như hình dưới, đang ngâm cứu chưa biết cách Sum nó trong mảng và nhóm nó theo [Tháng] theo [Máy] như thế nào. Cách truy vấn có subquery này buộc phải có cột STT.

rngData = "Data"

sSQL = "SELECT A.STT, A.NGAY, A.MAY,A.MAU,A.MA,(Select TOP 1 Mau From " & rngData & " As B Where B.STT > A.STT) AS MauKeTiep, IIf(A.Mau<>[MauKeTiep],1,0) AS DemMau, " & _
           "(Select TOP 1 Ma From " & rngData & " As C Where C.STT > A.STT) AS MaKeTiep, IIf(A.Ma<>[MaKeTiep],1,0) AS DemMa " & _
           "FROM " & rngData & " AS A;"

 

[HeSanbi]

Bài toán Bác đưa ra không biết có thiếu dữ kiện hay không, thấy sai logic

Điều kiện A = Nếu trong một ngày đổi thì đếm:
Điều kiện B = khác ngày đổi đếm hay không đếm?

Nếu B:
1. Đếm thì điều kiện A sẽ dư thừa -> loại bỏ A: Cứ tìm thấy khác thì đếm thêm 1 lần
2. Không đếm thì điều kiện A mới tồn tại -> vô lí

Tôi chỉ có thể giúp Bác luồng 1.
Code bên dưới việc đếm sẽ do Sub RepH thực hiện: Rất đơn giản dùng phân đoạn các giai đoạn để thực hiện đếm, và thêm các màu và mã đã được đổi.
Phức tạp nằm ở chổ tách kí hiệu Máy, tôi đã dùng phương pháp cộng dồn trong mảng với ký hiệu Máy ở các vị trí ngẫu nhiên.

Tôi đã không thêm giải thuật sắp xếp các tháng khớp nhau giữa các ký hiệu máy.
Vì chưa biết cách sắp xếp các tháng là tuần tự 1 đến 12 hay như thế nào,thường thì tháng sẽ là 1/19 , 2/19 ... 1/20, thấy bài toán đưa ra thiếu nhiều dữ kiện để thực hiện.
nên tôi chỉ có thể code đến đấy. Chờ thêm dữ kiện xem như thế nào.

Sub CountData()
  Dim D$(), tD, tArr, Arr, fArr(), rAr(), rMau(), rMa(), dArr()
  Dim tMay$, tMau$, tMa$, rc%
  Dim i&, j&, m&, n%, k%, tk%, k1%, k2%, lr&, lc%, UB&
  Dim Rng As Range
  With ThisWorkbook.Worksheets(1)
    With .Range("B4")
      lc = 4: lr = .End(xlDown).Row - .Row + 1
      tArr = .Resize(lr, lc).Value
    End With
    Set Rng = .Range("H30") 'Trả kết quả ở H30'
  End With
    If lr <= 0 Then Exit Sub
    For i = 1 To lr: GoSub RepArrH: Next
    For m = 1 To k1
      Arr = dArr(2, m): UB = UBound(Arr, 2)
      rc = (m - 1) * 5 + 1
      GoSub RepH
    Next
Ends: Set Rng = Nothing 'Erase toàn bộ mảng'
Exit Sub
RepArrH:
  GoSub LoopArr: UB = 1
  On Error Resume Next
  fArr = dArr(2, tk): If Err.Number = 0 Then UB = UBound(fArr, 2) + 1
  On Error GoTo 0
  ReDim Preserve fArr(1 To lc, 1 To UB)
  For j = 1 To lc: fArr(j, UB) = tArr(i, j): Next
  ReDim Preserve dArr(1 To 2, 1 To tk): dArr(1, tk) = tMay: dArr(2, tk) = fArr
Return
LoopArr:
  If k1 > 0 Or tMay <> vbNullString Then
    For j = 1 To k1
      If tArr(i, 2) = dArr(1, j) Then
        tMay = tArr(i, 2): tk = j: Erase fArr: Return
      End If
    Next
  End If
  tMay = tArr(i, 2): k1 = k1 + 1: tk = k1
Return
RepH:
  k = 0: k1 = 0: k2 = 0: Erase rMa: Erase rMau: Erase rAr
  For i = 1 To UB
    D = Split(CStr(Arr(1, i)), "/")
    If i > 1 Then
      If Int(Right$(D(2), 2)) = Int(Right$(tD(2), 2)) _
      And Int(D(1)) = Int(tD(1)) Then 'Month'
          If Arr(3, i) <> tMau Then GoSub RepMau
          If Arr(4, i) <> tMa Then GoSub RepMa
      Else: k = k + 1: GoSub Reset: End If 'Có 2 dòng vì cần ràng buộc cho đến khi mảng tD tồn tại'
    Else: k = k + 1: GoSub Reset: End If
    tD = D: tMau = Arr(3, i): tMa = Arr(4, i)
  Next
  Rng(rc, 0).Value = dArr(1, m)
  Rng(rc, 1).Resize(5, k).Value = rAr
Return

RepMau: k1 = k1 + 1: ReDim Preserve rMau(1 To k1): rMau(k1) = Arr(3, i): GoSub RepA: Return
RepMa: k2 = k2 + 1: ReDim Preserve rMa(1 To k2): rMa(k2) = Arr(4, i): GoSub RepA: Return
RepA:
  ReDim Preserve rAr(1 To 5, 1 To k)
  rAr(1, k) = D(1) & "/" & D(2)
  rAr(2, k) = k1: rAr(3, k) = Join(rMau, ","):
  rAr(4, k) = k2: rAr(5, k) = Join(rMa, ",")
Return
Reset: Erase rMau: Erase rMa: k1 = 0: k2 = 0: GoSub RepMau: GoSub RepMa: Return
End Sub