Xuất excel theo điều kiện

Blue Softs Liên hệ QC

tdt201012a8

Thành viên mới
Tham gia
26/8/20
Bài viết
6
Được thích
1
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
 

File đính kèm

  • mau1.xlsm
    16.1 KB · Đọc: 6

Hoàng Trọng Nghĩa

Chuyên gia GPE
Thành viên BQT
Moderator
Tham gia
17/8/08
Bài viết
8,418
Được thích
16,189
Giới tính
Nam
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

Thành viên mới
Tham gia
26/8/20
Bài viết
6
Được thích
1
Đâ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"
 

File đính kèm

  • quan ly kho demo.xlsm
    156.5 KB · Đọc: 8

Hoàng Trọng Nghĩa

Chuyên gia GPE
Thành viên BQT
Moderator
Tham gia
17/8/08
Bài viết
8,418
Được thích
16,189
Giới tính
Nam
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

Thành viên mới
Tham gia
26/8/20
Bài viết
6
Được thích
1
Để 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

Chuyên gia GPE
Thành viên BQT
Moderator
Tham gia
17/8/08
Bài viết
8,418
Được thích
16,189
Giới tính
Nam
Đú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.
Đú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:

1631925975007.png

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

Thành viên mới
Tham gia
26/8/20
Bài viết
6
Được thích
1
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
 
Top Bottom