Anh/chị giúp e tách cột TK của sổ NKC thành 2 cột như mẫu e để ở sheet1. E xin cảm ơn !!!

Chia sẻ bởi:hands

★★★★★

‹ Ứng dụng Class Module để viết hàm... Function Sort mảng 2 chiều ›

Quảng cáo

Anh/chị giúp e tách cột TK của sổ NKC thành 2 cột như mẫu e để ở sheet1. E xin cảm ơn !!!

Chỉnh mẫu lại dể nhìn hơn

Sub NKC()
  Dim sArr(), Res()
  Dim sRow&, i&, frow&, fR&, j&, no&, co&
  Dim tkNo$, tkCo$, tk911 As Boolean

Set Dic = CreateObject("scripting.dictionary")
  With Sheets("SNKC")
    i = .Range("I" & Rows.Count).End(xlUp).Row
    If .Range("E" & i) <> Empty Then
      sArr = .Range("B3:I" & i).Value
    Else
      sArr = .Range("B3:I" & i + 1).Value
      sArr(UBound(sArr), 4) = "zzz"
    End If
  End With

sRow = UBound(sArr) - 1
  ReDim Res(1 To sRow, 1 To 9)
  For i = 1 To sRow
    If sArr(i, 7) <> Empty Then
      no = no + 1: tkNo = sArr(i, 6)
    Else
      co = co + 1: tkCo = sArr(i, 6)
    End If
    If sArr(i, 4) <> Empty Then
      frow = i
      Res(k + 1, 1) = k + 1
      For j = 1 To 4
        Res(k + 1, j + 1) = sArr(i, j)
      Next j
    End If
    If sArr(i, 6) = "911" Then tk911 = True
    If sArr(i + 1, 4) <> Empty Then
      For r = frow To i
        If no = 1 Then
          If sArr(r, 8) > 0 Then
            k = k + 1
            Res(k, 6) = tkNo
            Res(k, 7) = sArr(r, 6)
            Res(k, 8) = sArr(r, 8)
          End If
        ElseIf co = 1 Then
          If sArr(r, 7) > 0 Then
            k = k + 1
            Res(k, 6) = sArr(r, 6)
            Res(k, 7) = tkCo
            Res(k, 8) = sArr(r, 7)
          End If
        ElseIf tk911 = True Then
          If sArr(r, 6) <> 911 Then
            If sArr(r, 7) > 0 Then
              k = k + 1
              Res(k, 6) = sArr(r, 6)
              Res(k, 7) = "911"
              Res(k, 8) = sArr(r, 7)
            Else
              k = k + 1
              Res(k, 6) = "911"
              Res(k, 7) = sArr(r, 6)
              Res(k, 8) = sArr(r, 8)
            End If
            Res(k, 9) = "k"
          Else
            Res(k, 9) = "Yes"
          End If
        Else
          If sArr(r, 7) > 0 Then
            k = k + 1
            If fR = 0 Then fR = k
            Res(k, 6) = sArr(r, 6)
            Res(k, 8) = sArr(r, 7)
            Res(k, 9) = "k"
          End If
          If r = i Then
            For r2 = frow To i
              If sArr(r2, 8) > 0 Then
                For i2 = fR To k
                  If Res(i2, 9) = "k" Then
                    If Res(i2, 8) = sArr(r2, 8) Then
                      Res(i2, 7) = sArr(r2, 6)
                      Res(i2, 9) = "Yes"
                      Exit For
                    End If
                  End If
                Next i2
              End If
            Next r2
          End If
        End If
      Next r
      no = 0: co = 0: tk911 = False
    End If
  Next i
  With Sheets("Sheet1")
    i = .Range("F" & Rows.Count).End(xlUp).Row
    If i > 2 Then .Range("A3:I" & i).Clear
    .Range("B3").Resize(k, 6).NumberFormat = "@"
    .Range("H3").Resize(k).NumberFormat = "#,###" '***
    .Range("A3").Resize(k, 8).Borders.LineStyle = 1
    .Range("A3").Resize(k, 8) = Res
  End With
End Sub

www.giaiphapexcel.com/diendan/threads/anh-ch%E1%BB%8B-gi%C3%BAp-e-t%C3%A1ch-c%E1%BB%99t-tk-c%E1%BB%A7a-s%E1%BB%95-nkc-th%C3%A0nh-2-c%E1%BB%99t-nh%C6%B0-m%E1%BA%ABu-e-%C4%91%E1%BB%83-%E1%BB%9F-sheet1-e-xin-c%E1%BA%A3m-%C6%A1n.155645/