Lấy Danh Mục Tổng từ các Danh Mục Con

[DMQ]

Chào các anh chị!!!
Em có 4 file, 1 File Tổng và 3 file con. Trong 4 file đều có sheet"DanhMuc" có cấu trúc giống nhau, 4 file này không nằm chung folder.
Nhờ các anh chị viết code lấy Danh Mục từ 3 file con về file Tổng. Danh mục của 3 file con sẽ có trùng, lần đầu lấy danh mục của 1 file, xong lần sau lấy danh mục tiếp sẽ lấy danh mục mà không trùng của lần trước.
Em có lấy mẫu trong file Tổng. Em chỉ làm cỡ 20 dòng dữ liệu, file thật có gần 1500 danh mục.
Mong các anh chị giúp đỡ.

 

[Tuhai2606]

mở mấy file xuong 1 2 3 nhìn chẳng hiểu nguyên tắc xây dựng file luôn á. nếu như bạn nói là chỉ cần tổng hợp các File cấu trúc giống nha thì nên nghiên cứu Power query

 

[DMQ]

Mấy file đó chỉ là ví dụ thôi bạn ơi, danh mục của mình khoảng 1500 loại, mình nắm tổng. Còn 3 người kia mỗi người 1 xưởng. Họ xuất nhập trên file của họ. 3 xưởng sẽ có danh mục trùng, và có danh mục không trùng, mình sẽ lấy damh mục của cả 3 xưởng lại để theo dõi tổng.

 

[HUONGHCKT]

Mấy file đó chỉ là ví dụ thôi bạn ơi, danh mục của mình khoảng 1500 loại, mình nắm tổng. Còn 3 người kia mỗi người 1 xưởng. Họ xuất nhập trên file của họ. 3 xưởng sẽ có danh mục trùng, và có danh mục không trùng, mình sẽ lấy damh mục của cả 3 xưởng lại để theo dõi tổng.

Trong khi chờ các giải pháp khác, bạn có thể tham khảo code sau

Sub DMQ()
    Dim fileList As Variant         '  Tap hop cac file can lay du lieu
    Dim File As Variant      ' File duoc chon mo trong tap hop fnameList
    Dim wbD As Workbook       ' workbook duoc mo
    Dim wbN As Workbook
    Dim Ws As Worksheet, Sh As Worksheet      ' Worksheet duoc chon
    Dim i&, j&, t&, Lr&
    Dim Dic As Object, Key
    Dim Arr(), KQ()
On Error GoTo Thoat
    fileList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)
 
  
'=======KHOA MAN HINH=================
            Application.DisplayAlerts = False
            Application.ScreenUpdating = False
           

        Set wbD = ActiveWorkbook         ' Gán bien cho Workbook dươc mơ
ReDim KQ(1 To 2000, 1 To 9)
Set Dic = CreateObject("Scripting.Dictionary")
For Each File In fileList   ' quet tung file trong tap hop
        Set wbN = Workbooks.Open(Filename:=File)          'mo file
    For Each Ws In wbN.Sheets
        If Ws.Name = "DanhMuc" Then
            Lr = Ws.Cells(Rows.Count, 2).End(xlUp).Row
            Arr = Ws.Range("A6:I" & Lr).Value
            For i = 1 To UBound(Arr)
                If Arr(i, 2) <> Empty Then
                    Key = Arr(i, 2)
                    If Not Dic.Exists(Key) Then
                        t = t + 1: Dic.Add (Key), t
                        KQ(t, 1) = t
                        For j = 2 To UBound(Arr, 2)
                            KQ(t, j) = Arr(i, j)
                        Next j
                    End If
                End If
            Next i
        End If
    Next Ws
        wbN.Close SaveChanges:=False
Next File
    Set Sh = Sheets("DanhMuc")
     If t Then
          Sh.Range("A6").Resize(10000, 9).ClearContents
          Sh.Range("A6").Resize(t, 9) = KQ
    End If
Thoat:
If Err Then
    MsgBox " Da có lôi say ra"
End If

    Set Dic = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

   End Sub

 

[DMQ]

Dạ cám ơn anh @HUONGHCKT đã giúp, em sẽ thử.

 

[DMQ]

Đúng rồi anh @HUONGHCKT , nhưng anh định dạng dùm em cột "Mã" thành dạng Text luôn được không ạ, và Sort tăng dần theo cột "Mã" luôn anh.

 

[HUONGHCKT]

nhưng anh định dạng dùm em cột "Mã" thành dạng Text luôn được không ạ

Bản thân kết quả sau khi chạy code Cột B đã là Text rồi mà.

và Sort tăng dần theo cột "Mã" luôn anh.

1/Bỏ dòng này:

KQ(t,1)=t

2/ Thay đoạn code sau

If t Then
          Sh.Range("A6").Resize(10000, 9).ClearContents
          Sh.Range("A6").Resize(t, 9) = KQ
    End If

Thành

If t Then
          Sh.Range("A6").Resize(10000, 9).ClearContents
          Sh.Range("A6").Resize(t, 9) = KQ
          Set Rng = Sh.Range("A6").Resize(t, 9) '.Select
        Call XepCot(Rng, 2)
       Sh.Range("A6").Resize(t, 1).FormulaR1C1 = "=IF(RC[1]<>""*"",MAX(R5C1:R[-1]C)+1,"""")"
    End If

3/ Thêm 1 sub này nữa ( đơn giản chỉ là ghi lại Macro mà thôi)

Sub XepCot(ByVal Rng As Range, Col As Integer)

Dim jRng As Range
Dim Sh As Worksheet

Set Sh = ActiveSheet
Set jRng = Sh.Range(Rng(1, Col), Rng(Rng.Rows.Count, col))

Rng.Select
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add2 Key:=jRng, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveSheet.Sort
        .SetRange Rng
        .Apply
    End With
  
End Sub

Thêm bớt dữ liệu ở các sheet nguồn và chay thử.
Xem file

 

[DMQ]

Em mới thử nạp danh mục mới vào và chạy thư thì lỗi anh @HUONGHCKT ơi.

 

[HUONGHCKT]

Em mới thử nạp danh mục mới vào và chạy thư thì lỗi anh @HUONGHCKT ơi.

1/ Bạn đã chạy thử với dữ liệu như các file bạn đăng lên chưa? Có lỗi không?
2/ Bạn muốn Sort từ nhỏ đến lớn ở cột B vậy thì Dòng mã này "A1620120" và "ST2.510010012000 " và ..... thì xếp thế nào? Đừng có nói là Lấy phần số của cái chuỗi trên để Sort nhé. Bạn có hiểu thế nào là Text và Number hay nói cách khác là thế nào là chuỗi và số không?
3/ Nó bị lỗi thế nào? ở dòng nào? sao bạn không đưa ảnh nên để mọi người cùng "thưởng thức" nhỉ? hay chỉ biết kêu là "thì lỗi" rồi?Nếu là bạn (một người quen cũ cũng biết về code VBA) bạn nghĩ gì? đừng có nói là tự tìm hiểu để sửa cho hoàn thiện và gửi lại đáp án nhé.
4/ Ngay từ đầu tôi đã nói với bạn "Trong khi chờ các giải pháp khác, bạn có thể tham khảo code sau". Nhắc lại điều này chắc bạn hiểu tôi muốn nói gì.
Thật buồn.

 

[DMQ]

Xin lỗi anh!!!!
Bảng danh mục của em có cả chuỗi và số, nên em nhờ anh chuyển hết sang Text dùm.

Bài đã được tự động gộp: 19/11/23

Lỗi đây ạ

và sau khi nhấn OK, thì hiện như sau

Không có số thứ tự ạ. Mong anh @HUONGHCKT xem dùm.