Form in bảng kê (1 người xem)

[HiLander]

nhờ anh chị viết code để khi chọn tên đại lý thì sẽ ra form giống như sheet khẩn cho đơn hàng khẩn và tương tự cho đơn hàng thường. em cám ơn.

 

[phucbugis]

nhờ anh chị viết code để khi chọn tên đại lý thì sẽ ra form giống như sheet khẩn cho đơn hàng khẩn và tương tự cho đơn hàng thường. em cám ơn.

bạn mở file đính kèm, cho chạy Macro

vào sheet Khan:
- chọn tên Đại lý, loại đơn hàng (ô M16)
- điền số liệu (footer) tại vùng L1:S13 (nếu có)
- click nút lọc bảng kê ---> xem kết quả

Public Sub [B]GPE_inbangke1[/B]() 'phuong thuc Find, Redim
Application.ScreenUpdating = False
Dim ArrData(), dArr(), rng As Range, sRng As Range
Dim i As Long, K As Long
    
    If Range("khan_tendaily") = "" Or Range("dk_loc1") = "" Then
        MsgBox ("Ban chua dien ten dai ly hoac loai don hang"), vbExclamation, "Thong bao'": Exit Sub
    End If
    
    With Sheets("Data")
        ArrData = .Range(.[A65536].End(xlUp), .[J2]).Value2
        If .AutoFilterMode Then .AutoFilterMode = False
    End With
    'tim ten dai ly tai sheet Danhsach
    Set rng = Sheets("Danhsach").Range("C3:C1000")
    Set sRng = rng.Find(Range("khan_tendaily"), , xlValues, xlWhole)
        If Not sRng Is Nothing Then
            tenDL = sRng.Offset(, -1).Value
        Else
            MsgBox ("Ko tim thay ten dai ly tai sheet Danhsach"), vbExclamation: Exit Sub
        End If
    
    ReDim dArr(1 To UBound(ArrData, 1), 1 To 10) 'xac dinh kich thuoc mang
    
    For i = 1 To UBound(ArrData, 1)
        If ArrData(i, 9) = tenDL And ArrData(i, 10) = Range("dk_loc1").Value Then
            K = K + 1
                    
            dArr(K, 1) = K                  'STT
            dArr(K, 2) = ArrData(i, 1)      'ma~ phu tung
            dArr(K, 3) = ArrData(i, 2)      'ten phu tung
            dArr(K, 4) = ArrData(i, 3)      'SL
            dArr(K, 5) = ArrData(i, 4)      'Don gia
            dArr(K, 6) = ArrData(i, 5)      'TT
            dArr(K, 7) = ArrData(i, 6)      'don dat hang
            dArr(K, 8) = ArrData(i, 7)      'so phieu xuat
            dArr(K, 9) = ArrData(i, 8)      'ngay xuat
            dArr(K, 10) = ArrData(i, 10)    'ghi chu
        End If
    Next i
    
    Range("B11:K1000").Clear
    If K Then
        Range("B11").Resize(K, 10) = dArr
        Call formatCells1
        Erase dArr
    End If
Application.ScreenUpdating = True
    
    Call copyPic1
MsgBox ("GPE_inbangke1 xong"), vbInformation
End Sub

Sub [B]formatCells1[/B]()
    Range([F65536].End(xlUp), [F11]).Resize(, 2).NumberFormat = "#,##0" 'don gia, TT
    Range([J65536].End(xlUp), [J11]).NumberFormat = "dd/mm/yy"          'ngay xuat
    Range([B65536].End(xlUp), [K11]).Borders.LineStyle = xlContinuous
End Sub

Sub [B]copyPic1[/B]()
'bi choi~ voi ScreenUpdating
    On Error Resume Next 'neu ko tim thay anh de? xoa'
    ActiveSheet.Shapes("MyPic1").Delete
    Range(Range("pic1").Value).CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    ActiveSheet.Paste Destination:=ActiveSheet.Range("C" & Rows.Count).End(xlUp).Offset(2)
    Selection.ShapeRange.Name = "MyPic1"
    
    Range("A1").Select 'vi dang chon Pic
End Sub

'- - -
mình chỉ mới cài cho sheet Khan.

Link: https://www.mediafire.com/?99f8ix918788hsf

'---
Chúc mọi người 1 ngày tốt lành !

 

[maytinhvp01]

nhờ anh chị viết code để khi chọn tên đại lý thì sẽ ra form giống như sheet khẩn cho đơn hàng khẩn và tương tự cho đơn hàng thường. em cám ơn.

Mình làm cho bạn phần sheet KHAN bạn tu làm tiep sheet con lai nhe!
mình dùng ADO

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rs As Object
Dim spath As String
Dim sql As String
Dim gt As String, i As Long, ran As Range
Dim arrstt, arrdl
Set con = CreateObject("ADODB.connection")
Set rs = CreateObject("ADODB.recordset")
spath = ThisWorkbook.Path & "\" & ThisWorkbook.Name
gt = Sheet2.Range("B9").Value
    If Target.Address = "$B$9" Then
        spath = ThisWorkbook.Path & "\" & ThisWorkbook.Name
        With con
            .Provider = "microsoft.ACE.OLEDB.12.0"
            .ConnectionString = "Data Source= " & spath & ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1"";"
            .CursorLocation = 3
            .Open
            sql = "SELECT f1,f2,f3,f4,f5,f6,f7,f8,f10" & " FROM [data$A2:J111] WHERE f9 like '" & gt & "'"
            rs.Open sql, con, 3, 3
            Sheet2.Range("A13:j6500").ClearContents
            Sheet2.[B13].CopyFromRecordset rs
        End With
        If Sheet2.Range("B13") <> "" Then
            For Each ran In Sheet2.Range("B13:B6500")
                If ran.Value <> "" Then
                    i = i + 1
                Else
                    Exit For
                End If
            Next
            ActiveSheet.ListObjects("Table5").Resize Range("$A$12:$J$" & 12 + i)
            arrstt = Sheet2.Range("A13:A" & 12 + i)
            For i = 1 To UBound(arrstt)
                arrstt(i, 1) = i
            Next
            Sheet2.Range("A13:A" & Sheet2.[A6500].End(xlUp).Row).Value = arrstt
            For i = 4 To 9
                Sheet2.[b6500].End(xlUp).Offset(1) = Sheet2.Range("K" & i)
            Next
            arrdl = Sheet2.Range("F13:F" & 12 + UBound(arrstt))
            For i = 1 To UBound(arrdl)
            tong = tong + arrdl(i, 1)
            Next
            Sheet2.[F6500].End(xlUp).Offset(1) = tong
        End If
    End If
End Sub

 

[HiLander]

cám ơn anh nhiều lắm !