Cập nhật dữ liệu từ File dữ liệu vào File Tổng

  • Thread starter Thread starter NoDiNaDu
  • Ngày gửi Ngày gửi
Liên hệ QC
NoDiNaDu

NoDiNaDu

Thành viên hoạt động
Tham gia
25/5/17
Bài viết
120
Được thích
47
Giới tính
Nam
Xin chào mọi người ạ. Hiện nay em đang cần cập nhật dữ liệu vào 1 File tổng từ 1 file excel khác, trong ấy lại có nhiều mục nhỏ.các mục được đánh dấu từ 1 trở đi, ví dụ mục A bắt đầu từ số 1, mục B cũng bắt đầu từ số 1, nên khó làm theo vlookup ( em làm thấy mất thời gian quá ạ).Mọi người có thể chỉ cho em cách nào để cập nhật dữ liệu nhanh hơn không ạ ?
File tổng của em là File Khối lượng, em cập nhật theo lần TT, lần này là ở Cột K
File dữ liệu của em là File TTL7, lấy dữ liệu ở cột H
Em xin cảm ơn ạ.
Các thầy HieuCD, Phan Thế Hiệp có rảnh xin giúp đỡ em với ạ.
 

File đính kèm

ngô đình cẩn đã viết:
Xin chào mọi người ạ. Hiện nay em đang cần cập nhật dữ liệu vào 1 File tổng từ 1 file excel khác, trong ấy lại có nhiều mục nhỏ.các mục được đánh dấu từ 1 trở đi, ví dụ mục A bắt đầu từ số 1, mục B cũng bắt đầu từ số 1, nên khó làm theo vlookup ( em làm thấy mất thời gian quá ạ).Mọi người có thể chỉ cho em cách nào để cập nhật dữ liệu nhanh hơn không ạ ?
File tổng của em là File Khối lượng, em cập nhật theo lần TT, lần này là ở Cột K
File dữ liệu của em là File TTL7, lấy dữ liệu ở cột H
Em xin cảm ơn ạ.
Các thầy HieuCD, Phan Thế Hiệp có rảnh xin giúp đỡ em với ạ.
Nhấp chuột vào đây để mở rộng...
Do bạn dùng biểu mẫu kiểu Word lại dùng cho Excel nên tự làm khó mình. 4 cấp STT ghi chung vào 1 cột rồi nhìn nhau "le lưỡi".
Nếu dữ liệu chuẩn, bạn có 4 cấp độ STT thì mỗi cột là 1 cấp.
Cấp 1: Các ký tự A, B, C,...
Cấp 2: Các ký tự I., II., III,....
Cấp 3: 1/, 2/, 3/ ...
Cấp 4: 1, 2, 3, ...
Lúc đó, làm gì cũng dễ.
Khi tạo báo cáo thì muốn làm gì tiếp thì làm.
4Cap.jpg
 
Ba Tê đã viết:
Do bạn dùng biểu mẫu kiểu Word lại dùng cho Excel nên tự làm khó mình. 4 cấp STT ghi chung vào 1 cột rồi nhìn nhau "le lưỡi".
Nếu dữ liệu chuẩn, bạn có 4 cấp độ STT thì mỗi cột là 1 cấp.
Cấp 1: Các ký tự A, B, C,...
Cấp 2: Các ký tự I., II., III,....
Cấp 3: 1/, 2/, 3/ ...
Cấp 4: 1, 2, 3, ...
Lúc đó, làm gì cũng dễ.
Khi tạo báo cáo thì muốn làm gì tiếp thì làm.
View attachment 218812
Nhấp chuột vào đây để mở rộng...
Dạ, đầu tiên e cảm ơn thầy đã quan tâm đến vấn đề của em, em xin lỗi vì không trả lời lại ngay được vì chủ nhật em được nghỉ làm mà máy thì để ở công ty. Em biết là quản lý phân cấp kiểu này rất khó, nhưng do khi tổng hợp và nhận dữ liệu thì em nhận lại từ 1 bên khác, việc phân cấp công việc do bên ấy thiết lập mà e chỉ đc làm theo người ta, nên không tự ý thay đổi được thầy ạ :(
 
ngô đình cẩn đã viết:
Xin chào mọi người ạ. Hiện nay em đang cần cập nhật dữ liệu vào 1 File tổng từ 1 file excel khác, trong ấy lại có nhiều mục nhỏ.các mục được đánh dấu từ 1 trở đi, ví dụ mục A bắt đầu từ số 1, mục B cũng bắt đầu từ số 1, nên khó làm theo vlookup ( em làm thấy mất thời gian quá ạ).Mọi người có thể chỉ cho em cách nào để cập nhật dữ liệu nhanh hơn không ạ ?
File tổng của em là File Khối lượng, em cập nhật theo lần TT, lần này là ở Cột K
File dữ liệu của em là File TTL7, lấy dữ liệu ở cột H
Em xin cảm ơn ạ.
Các thầy HieuCD, Phan Thế Hiệp có rảnh xin giúp đỡ em với ạ.
Nhấp chuột vào đây để mở rộng...
Các file nên cùng 1 thư mục, Chạy code
Mã: 
Sub GPE()
  Dim Dic As Object, iKey As String, Wb As Workbook, FileName As String
  Dim sArr(), Res(), Cap(1 To 4)
  Dim i As Long, j As Long, sRow As Long, k As Long, n As Long, jCol As Long
  Dim Tmp As String, Tmp1 As String, Tmp2 As String
  Const C1 = ".I.II.III.IV.V.VI.VII.VIII.IX."
  Const C2 = "/A/B/C/D/E/F/H/"
  Const C3 = "/I/II/III/IV/V/VI/VII/VIII/IX/"

  sArr = Range("A4:C" & Range("B" & Rows.Count).End(xlUp).Row + 1).Value
  sRow = UBound(sArr)
  ReDim Res(1 To sRow - 1, 1 To 1)
  Set Dic = CreateObject("scripting.dictionary")

  For i = 1 To sRow - 1
    Tmp1 = Application.Trim(sArr(i, 1)): Tmp2 = Replace(UCase(Application.Trim(sArr(i, 2))), ":", "")
    If InStr(1, Tmp2, ".") Then Tmp2 = Mid(Tmp2, 1, InStr(1, Tmp2, "."))
    If Len(sArr(i, 3)) = 0 Then
      If Len(Tmp1) + Len(Tmp2) > 0 Then
        If Len(Tmp1) > 0 Then Tmp = Tmp1 Else Tmp = Tmp2
        If InStr(1, C2, "/" & Tmp) Then
          k = 2: Cap(k) = Tmp
          n = 0
        ElseIf InStr(1, C1, "." & Tmp) Then
          k = 1: Cap(k) = Tmp
          n = 0
        ElseIf InStr(1, C3, "/" & Tmp) Then
          k = 3: Cap(k) = Tmp
          n = 0
        ElseIf IsNumeric(Mid(Tmp, 1, 1)) Then
          Tmp = Replace(Tmp, "/", ".")
          Tmp = Mid(Tmp, 1, InStr(1, Tmp, "."))
          k = 4: Cap(k) = Tmp
          n = 0
        Else
          n = n + 1
          k = 4: Cap(k) = n
        End If
      End If
      If Len(sArr(i + 1, 3)) > 0 Then
        Tmp = ""
        For j = 1 To k
          Tmp = Tmp & "#" & Cap(j)
        Next j
      End If
    Else
      iKey = Tmp & "#" & Tmp1 & "#" & Left(Tmp2, 10)
      Dic.Add iKey, i
    End If
  Next i
 
  FileName = GetFile(ThisWorkbook.Path)
  If Len(FileName) Then
    Tmp = UCase(FileName)
    For j = 5 To 11
      If InStr(1, Tmp, UCase(Cells(1, j))) Then
        jCol = j: Exit For
      End If
    Next j
'Ten file phai phu hop voi tieu de cot, neu khong phu hop cot se khong chay
    If jCol = 0 Then MsgBox ("Ten File khong dung tieu de cot"): Exit Sub
    Set Wb = Workbooks.Open(FileName)
    With Wb.Sheets(1)
      sArr = .Range("B7:J" & .Range("D" & Rows.Count).End(xlUp).Row + 1).Value
      sRow = UBound(sArr)
    End With
    Wb.Close False
    For i = 1 To sRow - 1
      Tmp1 = Application.Trim(sArr(i, 1)): Tmp2 = Replace(UCase(Application.Trim(sArr(i, 3))), ":", "")
      If InStr(1, Tmp2, ".") Then Tmp2 = Mid(Tmp2, 1, InStr(1, Tmp2, "."))
      If Len(sArr(i, 4)) = 0 Then
        If Len(Tmp1) + Len(Tmp2) > 0 Then
          If Len(Tmp1) > 0 Then Tmp = Tmp1 Else Tmp = Tmp2
          If InStr(1, C2, "/" & Tmp) Then
            k = 2: Cap(k) = Tmp
            n = 0
          ElseIf InStr(1, C1, "." & Tmp) Then
            k = 1: Cap(k) = Tmp
            n = 0
          ElseIf InStr(1, C3, "/" & Tmp) Then
            k = 3: Cap(k) = Tmp
            n = 0
          ElseIf IsNumeric(Mid(Tmp, 1, 1)) Then
            Tmp = Replace(Tmp, "/", ".")
            Tmp = Mid(Tmp, 1, InStr(1, Tmp, "."))
            k = 4: Cap(k) = Tmp
            n = 0
          Else
            n = n + 1
            k = 4: Cap(k) = n
          End If
        End If
        If Len(sArr(i + 1, 4)) > 0 Then
          Tmp = ""
          For j = 1 To k
            Tmp = Tmp & "#" & Cap(j)
          Next j
        End If
      Else
        iKey = Tmp & "#" & Tmp1 & "#" & Left(Tmp2, 10)
        If Dic.exists(iKey) = True Then
          Res(Dic.Item(iKey), 1) = sArr(i, 7)
        End If
      End If
    Next i
  End If
  Cells(4, jCol).Resize(UBound(Res)) = Res

End Sub

Function GetFile(ByVal strPath As String) As String
  Dim Fldr As FileDialog, sItem As String
  Set Fldr = Application.FileDialog(msoFileDialogFilePicker)
  With Fldr
    .AllowMultiSelect = False
    .InitialFileName = strPath
    .Filters.Add "Images", "*.xls*"
    If .Show <> -1 Then GoTo NextCode
    sItem = .SelectedItems(1)
  End With
NextCode:
  GetFile = sItem
  Set Fldr = Nothing
End Function
 

File đính kèm

HieuCD đã viết:
Các file nên cùng 1 thư mục, Chạy code
Mã: 
Sub GPE()
  Dim Dic As Object, iKey As String, Wb As Workbook, FileName As String
  Dim sArr(), Res(), Cap(1 To 4)
  Dim i As Long, j As Long, sRow As Long, k As Long, n As Long, jCol As Long
  Dim Tmp As String, Tmp1 As String, Tmp2 As String
  Const C1 = ".I.II.III.IV.V.VI.VII.VIII.IX."
  Const C2 = "/A/B/C/D/E/F/H/"
  Const C3 = "/I/II/III/IV/V/VI/VII/VIII/IX/"

  sArr = Range("A4:C" & Range("B" & Rows.Count).End(xlUp).Row + 1).Value
  sRow = UBound(sArr)
  ReDim Res(1 To sRow - 1, 1 To 1)
  Set Dic = CreateObject("scripting.dictionary")

  For i = 1 To sRow - 1
    Tmp1 = Application.Trim(sArr(i, 1)): Tmp2 = Replace(UCase(Application.Trim(sArr(i, 2))), ":", "")
    If InStr(1, Tmp2, ".") Then Tmp2 = Mid(Tmp2, 1, InStr(1, Tmp2, "."))
    If Len(sArr(i, 3)) = 0 Then
      If Len(Tmp1) + Len(Tmp2) > 0 Then
        If Len(Tmp1) > 0 Then Tmp = Tmp1 Else Tmp = Tmp2
        If InStr(1, C2, "/" & Tmp) Then
          k = 2: Cap(k) = Tmp
          n = 0
        ElseIf InStr(1, C1, "." & Tmp) Then
          k = 1: Cap(k) = Tmp
          n = 0
        ElseIf InStr(1, C3, "/" & Tmp) Then
          k = 3: Cap(k) = Tmp
          n = 0
        ElseIf IsNumeric(Mid(Tmp, 1, 1)) Then
          Tmp = Replace(Tmp, "/", ".")
          Tmp = Mid(Tmp, 1, InStr(1, Tmp, "."))
          k = 4: Cap(k) = Tmp
          n = 0
        Else
          n = n + 1
          k = 4: Cap(k) = n
        End If
      End If
      If Len(sArr(i + 1, 3)) > 0 Then
        Tmp = ""
        For j = 1 To k
          Tmp = Tmp & "#" & Cap(j)
        Next j
      End If
    Else
      iKey = Tmp & "#" & Tmp1 & "#" & Left(Tmp2, 10)
      Dic.Add iKey, i
    End If
  Next i

  FileName = GetFile(ThisWorkbook.Path)
  If Len(FileName) Then
    Tmp = UCase(FileName)
    For j = 5 To 11
      If InStr(1, Tmp, UCase(Cells(1, j))) Then
        jCol = j: Exit For
      End If
    Next j
'Ten file phai phu hop voi tieu de cot, neu khong phu hop cot se khong chay
    If jCol = 0 Then MsgBox ("Ten File khong dung tieu de cot"): Exit Sub
    Set Wb = Workbooks.Open(FileName)
    With Wb.Sheets(1)
      sArr = .Range("B7:J" & .Range("D" & Rows.Count).End(xlUp).Row + 1).Value
      sRow = UBound(sArr)
    End With
    Wb.Close False
    For i = 1 To sRow - 1
      Tmp1 = Application.Trim(sArr(i, 1)): Tmp2 = Replace(UCase(Application.Trim(sArr(i, 3))), ":", "")
      If InStr(1, Tmp2, ".") Then Tmp2 = Mid(Tmp2, 1, InStr(1, Tmp2, "."))
      If Len(sArr(i, 4)) = 0 Then
        If Len(Tmp1) + Len(Tmp2) > 0 Then
          If Len(Tmp1) > 0 Then Tmp = Tmp1 Else Tmp = Tmp2
          If InStr(1, C2, "/" & Tmp) Then
            k = 2: Cap(k) = Tmp
            n = 0
          ElseIf InStr(1, C1, "." & Tmp) Then
            k = 1: Cap(k) = Tmp
            n = 0
          ElseIf InStr(1, C3, "/" & Tmp) Then
            k = 3: Cap(k) = Tmp
            n = 0
          ElseIf IsNumeric(Mid(Tmp, 1, 1)) Then
            Tmp = Replace(Tmp, "/", ".")
            Tmp = Mid(Tmp, 1, InStr(1, Tmp, "."))
            k = 4: Cap(k) = Tmp
            n = 0
          Else
            n = n + 1
            k = 4: Cap(k) = n
          End If
        End If
        If Len(sArr(i + 1, 4)) > 0 Then
          Tmp = ""
          For j = 1 To k
            Tmp = Tmp & "#" & Cap(j)
          Next j
        End If
      Else
        iKey = Tmp & "#" & Tmp1 & "#" & Left(Tmp2, 10)
        If Dic.exists(iKey) = True Then
          Res(Dic.Item(iKey), 1) = sArr(i, 7)
        End If
      End If
    Next i
  End If
  Cells(4, jCol).Resize(UBound(Res)) = Res

End Sub

Function GetFile(ByVal strPath As String) As String
  Dim Fldr As FileDialog, sItem As String
  Set Fldr = Application.FileDialog(msoFileDialogFilePicker)
  With Fldr
    .AllowMultiSelect = False
    .InitialFileName = strPath
    .Filters.Add "Images", "*.xls*"
    If .Show <> -1 Then GoTo NextCode
    sItem = .SelectedItems(1)
  End With
NextCode:
  GetFile = sItem
  Set Fldr = Nothing
End Function
Nhấp chuột vào đây để mở rộng...
em cảm ơn thầy ạ
 
HieuCD đã viết:
Các file nên cùng 1 thư mục, Chạy code
Nhấp chuột vào đây để mở rộng...
Dạ thưa thầy, em chạy thử code thì lần 7 ok rồi ạ. Tuy nhiên lần 8 em chạy lại không được, code báo lỗi "Tên File không đúng tiêu đề cột" mặc dù em đã lưu chung các file vào 1 thư mục và đổi tên file dữ liệu đúng với cột mới, Thầy xem giùm em được không ạ ?
 

File đính kèm

ngô đình cẩn đã viết:
Dạ thưa thầy, em chạy thử code thì lần 7 ok rồi ạ. Tuy nhiên lần 8 em chạy lại không được, code báo lỗi "Tên File không đúng tiêu đề cột" mặc dù em đã lưu chung các file vào 1 thư mục và đổi tên file dữ liệu đúng với cột mới, Thầy xem giùm em được không ạ ?
Nhấp chuột vào đây để mở rộng...
Kiểm tra lại code
Mã: 
Sub GPE()
  Dim Dic As Object, iKey As String, Wb As Workbook, FileName As String
  Dim sArr(), Res(), Cap(1 To 4)
  Dim i As Long, j As Long, sRow As Long, k As Long, n As Long, jCol As Long
  Dim Tmp As String, Tmp1 As String, Tmp2 As String
  Const C1 = ".I.II.III.IV.V.VI.VII.VIII.IX."
  Const C2 = "/A/B/C/D/E/F/H/"
  Const C3 = "/I/II/III/IV/V/VI/VII/VIII/IX/"

  sArr = Range("A4:C" & Range("B" & Rows.Count).End(xlUp).Row + 1).Value
  sRow = UBound(sArr)
  ReDim Res(1 To sRow - 1, 1 To 1)
  Set Dic = CreateObject("scripting.dictionary")

  For i = 1 To sRow - 1
    Tmp1 = Application.Trim(sArr(i, 1)): Tmp2 = Replace(UCase(Application.Trim(sArr(i, 2))), ":", "")
    If InStr(1, Tmp2, ".") Then Tmp2 = Mid(Tmp2, 1, InStr(1, Tmp2, "."))
    If Len(sArr(i, 3)) = 0 Then
      If Len(Tmp1) + Len(Tmp2) > 0 Then
        If Len(Tmp1) > 0 Then Tmp = Tmp1 Else Tmp = Tmp2
        If InStr(1, C2, "/" & Tmp) Then
          k = 2: Cap(k) = Tmp
          n = 0
        ElseIf InStr(1, C1, "." & Tmp) Then
          k = 1: Cap(k) = Tmp
          n = 0
        ElseIf InStr(1, C3, "/" & Tmp) Then
          k = 3: Cap(k) = Tmp
          n = 0
        ElseIf IsNumeric(Mid(Tmp, 1, 1)) Then
          Tmp = Replace(Tmp, "/", ".")
          Tmp = Mid(Tmp, 1, InStr(1, Tmp, "."))
          k = 4: Cap(k) = Tmp
          n = 0
        Else
          n = n + 1
          k = 4: Cap(k) = n
        End If
      End If
      If Len(sArr(i + 1, 3)) > 0 Then
        Tmp = ""
        For j = 1 To k
          Tmp = Tmp & "#" & Cap(j)
        Next j
      End If
    Else
      iKey = Tmp & "#" & Tmp1 & "#" & Left(Tmp2, 10)
      Dic.Add iKey, i
    End If
  Next i
 
  FileName = GetFile(ThisWorkbook.Path)
  If Len(FileName) Then
    Tmp = UCase(FileName)
    For j = 5 To 100
      If InStr(1, Tmp, UCase(Cells(1, j))) Then
        jCol = j: Exit For
      End If
    Next j
'Ten file phai phu hop voi tieu de cot, neu khong phu hop cot se khong chay
    If jCol = 0 Then MsgBox ("Ten File khong dung tieu de cot"): Exit Sub
    Set Wb = Workbooks.Open(FileName, False)
    With Wb.Sheets(1)
      sArr = .Range("B7:J" & .Range("D" & Rows.Count).End(xlUp).Row + 1).Value
      sRow = UBound(sArr)
    End With
    Wb.Close False
    For i = 1 To sRow - 1
      Tmp1 = Application.Trim(sArr(i, 1)): Tmp2 = Replace(UCase(Application.Trim(sArr(i, 3))), ":", "")
      If InStr(1, Tmp2, ".") Then Tmp2 = Mid(Tmp2, 1, InStr(1, Tmp2, "."))
      If TypeName(sArr(i, 4)) = "Error" Then sArr(i, 4) = ""
      If TypeName(sArr(i + 1, 4)) = "Error" Then sArr(i + 1, 4) = ""
      If Len(sArr(i, 4)) = 0 Then
        If Len(Tmp1) + Len(Tmp2) > 0 Then
          If Len(Tmp1) > 0 Then Tmp = Tmp1 Else Tmp = Tmp2
          If InStr(1, C2, "/" & Tmp) Then
            k = 2: Cap(k) = Tmp
            n = 0
          ElseIf InStr(1, C1, "." & Tmp) Then
            k = 1: Cap(k) = Tmp
            n = 0
          ElseIf InStr(1, C3, "/" & Tmp) Then
            k = 3: Cap(k) = Tmp
            n = 0
          ElseIf IsNumeric(Mid(Tmp, 1, 1)) Then
            Tmp = Replace(Tmp, "/", ".")
            Tmp = Mid(Tmp, 1, InStr(1, Tmp, "."))
            k = 4: Cap(k) = Tmp
            n = 0
          Else
            n = n + 1
            k = 4: Cap(k) = n
          End If
        End If
        If Len(sArr(i + 1, 4)) > 0 Then
          Tmp = ""
          For j = 1 To k
            Tmp = Tmp & "#" & Cap(j)
          Next j
        End If
      Else
        iKey = Tmp & "#" & Tmp1 & "#" & Left(Tmp2, 10)
        If Dic.exists(iKey) = True Then
          Res(Dic.Item(iKey), 1) = sArr(i, 7)
        End If
      End If
    Next i
    Cells(4, jCol).Resize(UBound(Res)) = Res
  End If
End Sub
 
HieuCD đã viết:
Kiểm tra lại code
Nhấp chuột vào đây để mở rộng...

Dạ em làm được rồi thầy ạ, em cảm ơn thầy đã giúp đỡ em, tiện đây, thầy có thể giúp em phần này được không ạ ?
www.giaiphapexcel.com

Tạo cột STT phụ

Xin chào mọi người ạ. Hiện nay em đang có 1 File dữ liệu cần tổng hợp theo tháng, em đang muốn tạo 1 cột STT phụ để khi cần có thể xài hàm vlookup để dò cho tiện.Em đang loay hoay chưa biết làm thế nào, mong mn giúp em với ạ.(Hiện em đang để tạm mẫu phân cấp dạng 1.01.01.01, 1.01.01.02 Mọi người...
www.giaiphapexcel.com www.giaiphapexcel.com
Em xin cảm ơn ạ.
 
ngô đình cẩn đã viết:
Dạ em làm được rồi thầy ạ, em cảm ơn thầy đã giúp đỡ em, tiện đây, thầy có thể giúp em phần này được không ạ ?
www.giaiphapexcel.com

Tạo cột STT phụ

Xin chào mọi người ạ. Hiện nay em đang có 1 File dữ liệu cần tổng hợp theo tháng, em đang muốn tạo 1 cột STT phụ để khi cần có thể xài hàm vlookup để dò cho tiện.Em đang loay hoay chưa biết làm thế nào, mong mn giúp em với ạ.(Hiện em đang để tạm mẫu phân cấp dạng 1.01.01.01, 1.01.01.02 Mọi người...
www.giaiphapexcel.com www.giaiphapexcel.com
Em xin cảm ơn ạ.
Nhấp chuột vào đây để mở rộng...
File rút gọn và đã chỉnh sửa rất khó xử lý, nếu có file gốc ( chỉ cần các cột đầu) thì có thể xử lý được
 
HieuCD đã viết:
File rút gọn và đã chỉnh sửa rất khó xử lý, nếu có file gốc ( chỉ cần các cột đầu) thì có thể xử lý được
Nhấp chuột vào đây để mở rộng...
Dạ thưa thầy, File ban đầu đây ạ
Bài đã được tự động gộp:

HieuCD đã viết:
File rút gọn và đã chỉnh sửa rất khó xử lý, nếu có file gốc ( chỉ cần các cột đầu) thì có thể xử lý được
Nhấp chuột vào đây để mở rộng...
Nếu có thể, thầy có thể giúp em bằng cách dùng hàm không ạ ?
em Group vào để tiện theo dõi, việc bỏ Group không quan trọng nên thầy có thể phá Group để tiện hơn ạ
 

File đính kèm

ngô đình cẩn đã viết:
Dạ thưa thầy, File ban đầu đây ạ
Bài đã được tự động gộp:


Nếu có thể, thầy có thể giúp em bằng cách dùng hàm không ạ ?
em Group vào để tiện theo dõi, việc bỏ Group không quan trọng nên thầy có thể phá Group để tiện hơn ạ
Nhấp chuột vào đây để mở rộng...
Dùng hàm phức tạp, code dể xử lý hơn
Mã: 
Sub MaPhanCap()
  Dim iKey As String
  Dim sArr(), Res(), Cap(1 To 5) As Long
  Dim i As Long, j As Long, sRow As Long, k As Long, n As Long, jCol As Long
  Dim Tmp As String, Tmp1 As String, Tmp2 As String
 
  sArr = Range("B4:D" & Range("C" & Rows.Count).End(xlUp).Row).Value
  sRow = UBound(sArr)
  ReDim Res(1 To sRow, 1 To 1)

  For i = 1 To sRow
    Tmp1 = Application.Trim(sArr(i, 1))
    Tmp2 = Replace(Application.Trim(sArr(i, 2)), "/", ".")
    If InStr(1, Tmp2, ".") Then Tmp2 = Mid(Tmp2, 1, InStr(1, Tmp2, "."))
    
    If Len(Tmp1) + Len(Tmp2) > 0 Then
      If Len(sArr(i, 3)) = 0 Then
        If Len(Tmp1) > 0 Then Tmp = Tmp1 Else Tmp = Tmp2
        If InStr(1, Tmp, "-") Then
          k = 1
        ElseIf InStr(1, Tmp, "/") Then
          k = 2
        ElseIf IsNumeric(Mid(Tmp, 1, 1)) And InStr(1, Tmp, ".") > 0 Then
          k = 4
        Else
          k = 3
        End If
        Cap(k) = Cap(k) + 1
        For j = k + 1 To 5
           Cap(j) = 0
        Next j
        Tmp = Format(Cap(1), "0")
        For j = 2 To k
          Tmp = Tmp & "_" & Format(Cap(j), "00")
        Next j
        Res(i, 1) = Tmp
      Else
        If Len(Tmp1) > 0 Then
          Cap(5) = Cap(5) + 1
          Tmp = Format(Cap(1), "0")
          For j = 2 To 5
            Tmp = Tmp & "_" & Format(Cap(j), "00")
          Next j
          Res(i, 1) = Tmp
        End If
      End If
    End If
  Next i
  With CreateObject("scripting.dictionary") 'Kiem tra trung ma
    For i = 1 To UBound(Res)
      If Len(Res(i, 1)) Then .Add (Res(i, 1)), ""
    Next
  End With
  Range("A4").Resize(UBound(Res)).NumberFormat = "@"
  Range("A4").Resize(UBound(Res)) = Res
End Sub
 

File đính kèm

ngô đình cẩn đã viết:
Dạ em cảm ơn thầy ạ, thầy ơi em muốn lấy code này để làm với các File có cấu trúc tương tự liệu có được không ạ ?
Nhấp chuột vào đây để mở rộng...
Cấu trúc tương tự phải theo chuẩn:
- Dữ liệu phân thành 5 cấp
- Dữ liệu có 3 cột, cột thứ 3 có dữ liệu là cấp 5, không có là cấp 1 tới 4
- Cấp 1 tới 4 nhận diện qua:
+ "-" là cấp 1
+ "/" là cấp 2
+ "." và dạng số là cấp 4
+ Còn lại là cấp 3
Dùng Function cho bạn dể sử dung, thay đổi vùng dữ liệu ở sub main
Mã: 
Sub Main()
  Dim sArr(), Res As Variant, eRow As Long
  eRow = Range("C" & Rows.Count).End(xlUp).Row 'Dong cuoi
  If eRow < 7 Then MsgBox ("Khong co du lieu"): Exit Sub
  sArr = Range("B4:D" & eRow).Value 'Vung du lieu
  Res = ChiaCap(sArr)
  If TypeName(Res) = "Variant()" Then
    Range("A4").Resize(UBound(Res)).NumberFormat = "@"
    Range("A4").Resize(UBound(Res)) = Res
  Else
    MsgBox ("Du lieu khong chuan, Khong tao duoc ma")
  End If
End Sub
Function ChiaCap(ByVal sArr As Variant) As Variant
  Dim Res(), Cap(1 To 5) As Long
  Dim i As Long, j As Long, sRow As Long, k As Long, n As Long, jCol As Long
  Dim Tmp As String, Tmp1 As String, Tmp2 As String

  sRow = UBound(sArr)
  ReDim Res(1 To sRow, 1 To 1)
  For i = 1 To sRow
    Tmp1 = Application.Trim(sArr(i, 1))
    Tmp2 = Replace(Application.Trim(sArr(i, 2)), "/", ".")
    If InStr(1, Tmp2, ".") Then Tmp2 = Mid(Tmp2, 1, InStr(1, Tmp2, "."))
   
    If Len(Tmp1) + Len(Tmp2) > 0 Then
      If Len(sArr(i, 3)) = 0 Then
        If Len(Tmp1) > 0 Then Tmp = Tmp1 Else Tmp = Tmp2
        If InStr(1, Tmp, "-") Then
          k = 1
        ElseIf InStr(1, Tmp, "/") Then
          k = 2
        ElseIf IsNumeric(Mid(Tmp, 1, 1)) And InStr(1, Tmp, ".") > 0 Then
          k = 4
        Else
          k = 3
        End If
        Cap(k) = Cap(k) + 1
        For j = k + 1 To 5
           Cap(j) = 0
        Next j
        Tmp = Format(Cap(1), "0")
        For j = 2 To k
          Tmp = Tmp & "_" & Format(Cap(j), "00")
        Next j
        Res(i, 1) = Tmp
      Else
        If Len(Tmp1) > 0 Then
          Cap(5) = Cap(5) + 1
          Tmp = Format(Cap(1), "0")
          For j = 2 To 5
            Tmp = Tmp & "_" & Format(Cap(j), "00")
          Next j
          Res(i, 1) = Tmp
        End If
      End If
    End If
  Next i
  With CreateObject("scripting.dictionary") 'Kiem tra trung ma
    For i = 1 To UBound(Res)
      If Len(Res(i, 1)) Then
        If .exists(Res(i, 1)) Then MsgBox ("Du lieu khong chuan, Khong tao duoc ma"): Exit Function
        .Add (Res(i, 1)), ""
      End If
    Next
  End With
  ChiaCap = Res
End Function
 

File đính kèm

Dạ, em cảm ơn thầy ạ. Em chúc thầy ngày mới tốt lành ạ.
 
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

HeSanbi
  • Đã giải quyết
LocalizeXL v1.73 - Làm nổi bật ô đang chọn và cuộn trang tự động
    • Thích
    • Yêu thích
2 3 4
Trả lời
68
Đọc
10K
125479980
125479980
VietHoangPhan
Excel lỗi không hiển thị dữ liệu, dãn dòng tất cả các file
Trả lời
2
Đọc
21
VietHoangPhan
VietHoangPhan
V
  • Question Question
Tách số liệu từ bảng tính ngang theo điều kiện
Trả lời
13
Đọc
251
HieuCD
H
F
Ẩn công thức trong Google Sheets
Trả lời
2
Đọc
25
FATA11
F
P
Xin trợ giúp cách lập lịch trực tịnh tiến dần cho 1 nhóm người.
Trả lời
2
Đọc
66
Phuocam
Phuocam
minhquipk
  • Question Question
Cách nhận biết những ô đã bị thay đổi giá trị khi thay đổi giá trị dữ liệu ở những ô khác
Trả lời
3
Đọc
79
le_vis
L
H
Tìm kết quả trả về theo loại
Trả lời
9
Đọc
87
VetMini
V
LongHoang123
  • Question Question
Xin hướng dẫn: Cách tạo vùng in dựa trên dữ liệu của listbox bằng VBA!!!
Trả lời
4
Đọc
91
LongHoang123
LongHoang123
M
  • Question Question
"thủ tục để xóa dòng trống " trong Lập trình VBA trong Excel
2 3 4
Trả lời
63
Đọc
15K
SonBDND
S
Q
Hỏi về công thức dò giá
Trả lời
6
Đọc
187
thanthanhan0801
T
N
  • Question Question
VBA - copy các sheets unhide và dạng giá trị theo vùng xác định
Trả lời
6
Đọc
332
nguyenhuong34
nguyenhuong34
ThanhPhongDN
hỏi về cách thay đổi giá trị một ô sau khi nhập một giá trị vào đó
Trả lời
7
Đọc
140
vietduc147258
V
huuthang_bd
Add-in DeleteVirusMacro - Xóa và ngăn chặn virus macro
    • Thích
    • Yêu thích
    • Chấp nhận
2
Trả lời
34
Đọc
13K
hungbon7890
hungbon7890
A
  • Question Question
code vba chuyển chuỗi thành text
Trả lời
11
Đọc
2K
SonBDND
S
V
Xin giúp em file theo dõi thanh toán có bị quá hạn không, quá bao nhiêu ngày và bao nhiêu tiền ạ
Trả lời
11
Đọc
313
HUONGHCKT
H
Tandattb
Xin cách Khắc phục lỗi "Path/File access error"
Trả lời
8
Đọc
314
Tandattb
Tandattb
ThanhPhongDN
Nhờ giúp đỡ về công thức trong google sheet
    • Cười
Trả lời
4
Đọc
87
thuytrangbp28
T
saobekhonglac
Tạo form vòng quay may mắn
    • Thích
2
Trả lời
35
Đọc
15K
VetMini
V
D
Thống kê dữ liệu theo điều kiện
Trả lời
5
Đọc
142
VetMini
V
noisy
Xin file tính chế độ chuyên cần
    • Cười
Trả lời
0
Đọc
48
noisy
noisy
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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
Chúc mừng năm mới.
Back
Top Bottom