Xuất excel theo điều kiện (4 người xem)

tdt201012a8 · 17/9/21

Hi Team
Mình có câu hỏi này nhờ team giúp mình với.
Mình muốn xuất excel theo điều kiện ở bên listbox. Chẳng hạn mình muốn xuất ra file excel riêng với "a" hoặc "b"... trong bảng dựa vào list. List chọn "a" thì excel sẽ xuất toàn "a".
Mình xin cảm ơn
Email: thuan.tran@dinhcao.biz

Hoàng Trọng Nghĩa · 17/9/21

tdt201012a8 đã viết:
Hi Team
Mình có câu hỏi này nhờ team giúp mình với.
Mình muốn xuất excel theo điều kiện ở bên listbox. Chẳng hạn mình muốn xuất ra file excel riêng với "a" hoặc "b"... trong bảng dựa vào list. List chọn "a" thì excel sẽ xuất toàn "a".
Mình xin cảm ơn
Email: thuan.tran@dinhcao.biz

Đây là code của nút Xuất:

Mã:

Private Sub xuat_Click()
    If danh_sach.MatchFound Then
        Dim arrCopy, arrPaste
        Dim n As Long, r As Long, u As Long
        arrCopy = Sheets("Mau").Range("A1:B11").Value
        u = UBound(arrCopy)
        ReDim arrPaste(1 To u, 1 To 2)
        For r = 1 To u
            If arrCopy(r, 2) = danh_sach.Text Then
                n = n + 1
                arrPaste(n, 1) = arrCopy(r, 1)
                arrPaste(n, 2) = arrCopy(r, 2)
            End If
        Next
        Dim nwb As Workbook
        Set nwb = Workbooks.Add
        nwb.Sheets(1).Range("A1").Resize(n, 2).Value = arrPaste
    End If
End Sub

tdt201012a8 · 18/9/21

Hoàng Trọng Nghĩa đã viết:

Đây là code của nút Xuất:

Mã:

Private Sub xuat_Click()
    If danh_sach.MatchFound Then
        Dim arrCopy, arrPaste
        Dim n As Long, r As Long, u As Long
        arrCopy = Sheets("Mau").Range("A1:B11").Value
        u = UBound(arrCopy)
        ReDim arrPaste(1 To u, 1 To 2)
        For r = 1 To u
            If arrCopy(r, 2) = danh_sach.Text Then
                n = n + 1
                arrPaste(n, 1) = arrCopy(r, 1)
                arrPaste(n, 2) = arrCopy(r, 2)
            End If
        Next
        Dim nwb As Workbook
        Set nwb = Workbooks.Add
        nwb.Sheets(1).Range("A1").Resize(n, 2).Value = arrPaste
    End If
End Sub

Cảm ơn nhiều. Nhưng khi mình đưa code vào file chính thì lại ko dc. Mình up file lên xem giúp mình thử. Vị trí cần làm là textbox và xuất excel mà mình tô màu đỏ. Dữ liệu cần xuất ra file khác là sheet "Hien_Thi"

Hoàng Trọng Nghĩa · 18/9/21

tdt201012a8 đã viết:
Cảm ơn nhiều. Nhưng khi mình đưa code vào file chính thì lại ko dc. Mình up file lên xem giúp mình thử. Vị trí cần làm là textbox và xuất excel mà mình tô màu đỏ. Dữ liệu cần xuất ra file khác là sheet "Hien_Thi"

Để mai rảnh tôi xem rồi làm luôn cho, nhưng khi lên form, điều kiện xuất sao không lọc duy nhất luôn để mà dễ chọn. Còn nữa, mỗi cái combobox đều được add một khoảng trắng thêm chi vậy cà? Để đỡ mất công xóa hả?

tdt201012a8 · 18/9/21

Hoàng Trọng Nghĩa đã viết:
Để mai rảnh tôi xem rồi làm luôn cho, nhưng khi lên form, điều kiện xuất sao không lọc duy nhất luôn để mà dễ chọn. Còn nữa, mỗi cái combobox đều được add một khoảng trắng thêm chi vậy cà? Để đỡ mất công xóa hả?

Đúng rồi, mình cũng đang tìm hiểu làm sao để về duy nhất mà tới 2h sáng chưa ngủ. Nếu dc giúp mình thêm với nha, cái này càng nghĩ thì càng bế tắc. Còn add khoảng trắng để khi thêm xong thì sẽ trả về giá trị trống.

Hoàng Trọng Nghĩa · 18/9/21

tdt201012a8 đã viết:
Đúng rồi, mình cũng đang tìm hiểu làm sao để về duy nhất mà tới 2h sáng chưa ngủ. Nếu dc giúp mình thêm với nha, cái này càng nghĩ thì càng bế tắc. Còn add khoảng trắng để khi thêm xong thì sẽ trả về giá trị trống.

Bạn lưu ý vấn đề này nha:

Sau khi lọc duy nhất ra kết quả như trên, bạn cần đồng nhất tên lại nha, không thôi dữ liệu của một người thành 2 người ráng chịu!

Tôi đã sửa một số code nạp dữ liệu cho bạn:

PHP:

Private Sub UserForm_Initialize()
    txt_start.Value = Format("01/01/2021", "dd / mm / yyyy")
    txt_end.Value = Format(Date, "dd / mm / yyyy")
    txt_date.Value = Format(Date, "dd / mm / yyyy")
    
    cmb_giao_dich.List = Array("Nhap Kho", "Xuat Kho", "Sua Chua", "Thanh Ly", "Da Sua", "Nhap Lai")
    
    Dim e As Long
    Dim shtSP As Worksheet, shtXP As Worksheet
    
    Set shtSP = ThisWorkbook.Sheets("SP")
    Set shtXP = ThisWorkbook.Sheets("XP")
    
    e = shtSP.Range("B" & shtSP.Rows.Count).End(xlUp).Row
    cmb_san_pham.List = shtSP.Range("B2:B" & e).Value
    
    Dim r As Long
    Dim arrNguoiTH
    e = shtXP.Range("M" & shtXP.Rows.Count).End(xlUp).Row
    arrNguoiTH = shtXP.Range("M2:M" & e).Value
    
    ''Loc duy nhat:
    Dim ObjDict As Object
    Set ObjDict = CreateObject("Scripting.Dictionary")
    For r = 1 To UBound(arrNguoiTH)
        If Not ObjDict.Exists(arrNguoiTH(r, 1)) Then
            ObjDict(arrNguoiTH(r, 1)) = ""
        End If
    Next
    cmb_nhan_vien.List = ObjDict.Keys
    Set ObjDict = Nothing
    
    Call hien_thi_giao_dich
    Call hien_thi_kho
    Call hien_thi_bao_cao
End Sub

Nút lệnh xuất file Excel kho của bạn đây:

PHP:

Private Sub cmb_xuat_excel_kho_Click()
    If cmb_nhan_vien.MatchFound Then
        Dim c As Byte
        Dim shtHienThi As Worksheet
        Dim arrCopy, arrPaste, arrHeader
        Dim e As Long, n As Long, r As Long, u As Long
        Set shtHienThi = ThisWorkbook.Sheets("Hien_Thi")
        
        arrHeader = Sheets("Hien_Thi").Range("A1:M1").Value
        
        e = shtHienThi.Range("B" & shtHienThi.Rows.Count).End(xlUp).Row
        arrCopy = Sheets("Hien_Thi").Range("A2:M" & e).Value
        u = UBound(arrCopy)
        
        ReDim arrPaste(1 To u, 1 To 13)
        For r = 1 To u
            If arrCopy(r, 13) = cmb_nhan_vien.Text Then
                n = n + 1
                arrPaste(n, 1) = n
                For c = 2 To 13
                    arrPaste(n, c) = arrCopy(r, c)
                Next
            End If
        Next
        
        Dim nwb As Workbook
        Set nwb = Workbooks.Add
        nwb.Sheets(1).Range("A1:M1").Value = arrHeader
        nwb.Sheets(1).Range("A2:M2").Resize(n).Value = arrPaste
        
        Unload Me
    End If
End Sub

tdt201012a8 · 18/9/21

Hoàng Trọng Nghĩa đã viết:

Bạn lưu ý vấn đề này nha:

View attachment 266271

Sau khi lọc duy nhất ra kết quả như trên, bạn cần đồng nhất tên lại nha, không thôi dữ liệu của một người thành 2 người ráng chịu!

Tôi đã sửa một số code nạp dữ liệu cho bạn:

PHP:

Private Sub UserForm_Initialize()
    txt_start.Value = Format("01/01/2021", "dd / mm / yyyy")
    txt_end.Value = Format(Date, "dd / mm / yyyy")
    txt_date.Value = Format(Date, "dd / mm / yyyy")
   
    cmb_giao_dich.List = Array("Nhap Kho", "Xuat Kho", "Sua Chua", "Thanh Ly", "Da Sua", "Nhap Lai")
   
    Dim e As Long
    Dim shtSP As Worksheet, shtXP As Worksheet
   
    Set shtSP = ThisWorkbook.Sheets("SP")
    Set shtXP = ThisWorkbook.Sheets("XP")
   
    e = shtSP.Range("B" & shtSP.Rows.Count).End(xlUp).Row
    cmb_san_pham.List = shtSP.Range("B2:B" & e).Value
   
    Dim r As Long
    Dim arrNguoiTH
    e = shtXP.Range("M" & shtXP.Rows.Count).End(xlUp).Row
    arrNguoiTH = shtXP.Range("M2:M" & e).Value
   
    ''Loc duy nhat:
    Dim ObjDict As Object
    Set ObjDict = CreateObject("Scripting.Dictionary")
    For r = 1 To UBound(arrNguoiTH)
        If Not ObjDict.Exists(arrNguoiTH(r, 1)) Then
            ObjDict(arrNguoiTH(r, 1)) = ""
        End If
    Next
    cmb_nhan_vien.List = ObjDict.Keys
    Set ObjDict = Nothing
   
    Call hien_thi_giao_dich
    Call hien_thi_kho
    Call hien_thi_bao_cao
End Sub

Nút lệnh xuất file Excel kho của bạn đây:

PHP:

Private Sub cmb_xuat_excel_kho_Click()
    If cmb_nhan_vien.MatchFound Then
        Dim c As Byte
        Dim shtHienThi As Worksheet
        Dim arrCopy, arrPaste, arrHeader
        Dim e As Long, n As Long, r As Long, u As Long
        Set shtHienThi = ThisWorkbook.Sheets("Hien_Thi")
       
        arrHeader = Sheets("Hien_Thi").Range("A1:M1").Value
       
        e = shtHienThi.Range("B" & shtHienThi.Rows.Count).End(xlUp).Row
        arrCopy = Sheets("Hien_Thi").Range("A2:M" & e).Value
        u = UBound(arrCopy)
       
        ReDim arrPaste(1 To u, 1 To 13)
        For r = 1 To u
            If arrCopy(r, 13) = cmb_nhan_vien.Text Then
                n = n + 1
                arrPaste(n, 1) = n
                For c = 2 To 13
                    arrPaste(n, c) = arrCopy(r, c)
                Next
            End If
        Next
       
        Dim nwb As Workbook
        Set nwb = Workbooks.Add
        nwb.Sheets(1).Range("A1:M1").Value = arrHeader
        nwb.Sheets(1).Range("A2:M2").Resize(n).Value = arrPaste
       
        Unload Me
    End If
End Sub

Cảm ơn bạn nhiều. Chúc bạn thật nhiều vui vẻ. Cho mình xin zalo của bạn đi, để mình tương tác nhiều hơn

Hoàng Trọng Nghĩa · 18/9/21

tdt201012a8 đã viết:
Cảm ơn bạn nhiều. Chúc bạn thật nhiều vui vẻ. Cho mình xin zalo của bạn đi, để mình tương tác nhiều hơn

:

Xuất excel theo điều kiện (4 người xem)

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

tdt201012a8

Thành viên mới

File đính kèm

Hoàng Trọng Nghĩa

Chuyên gia GPE

tdt201012a8

Thành viên mới

File đính kèm

Hoàng Trọng Nghĩa

Chuyên gia GPE

tdt201012a8

Thành viên mới

Hoàng Trọng Nghĩa

Chuyên gia GPE

tdt201012a8

Thành viên mới

Hoàng Trọng Nghĩa

Chuyên gia GPE

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

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