Lọc theo mã sang Sheet khác (6 người xem)

[tuyettrang186]

Nhờ anh chị viết dùm em code lọc trong ví dụ dưới đây.

 

[NH_DK]

Nhờ anh chị viết dùm em code lọc trong ví dụ dưới đây.

Dạng bài này trên GPE có rất nhiều mà bạn? Bạn tìm nhé!

 

[ngh_khanh]

Nhờ anh chị viết dùm em code lọc trong ví dụ dưới đây.

Bạn dùng sự kiện Change nhé:

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    On Error Resume Next
    If Target.Address = "$C$1" Then
        Range("A5:F65000").ClearContents
        With S1.Range(S1.[A6], S1.[A65000].End(3)).Resize(, 6)
            .AutoFilter 2, Range("C1")
            Union(.Resize(, 1).Offset(1, 0), .Offset(1, 2).Resize(, 4)).SpecialCells(12).Copy Range("A5")
            .AutoFilter
        End With
    End If
End Sub

 

[ThuNghi]

Bạn dùng sự kiện Change nhé:

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    On Error Resume Next
    If Target.Address = "$C$1" Then
        Range("A5:F65000").ClearContents
        With S1.Range(S1.[A6], S1.[A65000].End(3)).Resize(, 6)
            .AutoFilter 2, Range("C1")
            Union(.Resize(, 1).Offset(1, 0), .Offset(1, 2).Resize(, 4)).SpecialCells(12).Copy Range("A5")
            .AutoFilter
        End With
    End If
End Sub

Thấy bạn có msg hỏi về array, vậy bây giờ tôi làm lại theo hướng range, nghiên cứu đi và chuyển sang array.

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Target.Address = "$C$1" Then
      Range("A5:F65000").ClearContents
      LocRng
    End If
End Sub
Sub LocRng()
Dim myRng As Range, sMa As String
Dim iR As Long, iC As Long, fR As Long
With Application
  .ScreenUpdating = False: .EnableEvents = False
End With
sMa = S2.[C1]: fR = 4
With S1
  Set myRng = .Range(.[A7], .[A65000].End(3)).Resize(, 6)
  With myRng
    For iR = 1 To myRng.Rows.Count
      If myRng(iR, 2) = sMa Then
        fR = fR + 1
        S2.Cells(fR, 1) = myRng(iR, 1) 'ngay
        For iC = 3 To 5 'chi tiet
          S2.Cells(fR, iC - 1) = myRng(iR, iC)
        Next iC
      End If
    Next iR
  End With
End With
Set myRng = Nothing
With Application
  .ScreenUpdating = True: .EnableEvents = True
End With
End Sub

Hiểu sẽ hướng dẫn thay myRng = myArr.
Chúc thành công.

 

[ndu96081631]

Hiểu sẽ hướng dẫn thay myRng = myArr.
Chúc thành công.

Vầy được không
1> Trong Module

Sub sFilter(sRng As Range, Criteria, Col As Long, Target As Range)
  Dim tmpArr, Arr, i As Long, j As Long, n As Long
  On Error GoTo ExitSub
  tmpArr = sRng.Value
  ReDim Arr(1 To UBound(tmpArr, 1), 1 To UBound(tmpArr, 2))
  For i = 1 To UBound(tmpArr, 1)
    If tmpArr(i, Col) = Criteria Then
      n = n + 1
      For j = 1 To UBound(tmpArr, 2)
        Arr(n, j) = tmpArr(i, j)
      Next j
    End If
  Next i
  Target.Resize(n, j - 1).Value = Arr
ExitSub:
End Sub

2> Trong sheet2

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim sRng As Range, Criteria, Col As Long
  If Target.Address = "$C$1" Then
    Range("A5:F60000").Clear
    Set sRng = Sheet1.Range(Sheet1.[A7], Sheet1.[A65536].End(xlUp)).Resize(, 6)
    Col = 2
    sFilter sRng, Target.Value, Col, Range("A5")
  End If
End Sub

 

[ngh_khanh]

Thấy bạn có msg hỏi về array, vậy bây giờ tôi làm lại theo hướng range, nghiên cứu đi và chuyển sang array.

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Address = "$C$1" Then
Range("A5:F65000").ClearContents
LocRng
End If
End Sub
Sub LocRng()
Dim myRng As Range, sMa As String
Dim iR As Long, iC As Long, fR As Long
With Application
.ScreenUpdating = False: .EnableEvents = False
End With
sMa = S2.[C1]: fR = 4
With S1
Set myRng = .Range(.[A7], .[A65000].End(3)).Resize(, 6)
With myRng
For iR = 1 To myRng.Rows.Count
If myRng(iR, 2) = sMa Then
fR = fR + 1
S2.Cells(fR, 1) = myRng(iR, 1) 'ngay
For iC = 3 To 5 'chi tiet
S2.Cells(fR, iC - 1) = myRng(iR, iC)
Next iC
End If
Next iR
End With
End With
Set myRng = Nothing
With Application
.ScreenUpdating = True: .EnableEvents = True
End With
End Sub

Hiểu sẽ hướng dẫn thay myRng = myArr.
Chúc thành công.

Anh ơi, dòng này:

For iC = 3 To 5 'chi tiet

thành:

For iC = 3 To 6 'chi tiet

Thì cột t_tiền mới có dữ liệu.
Một lần nữa cám ơn bác về ví dụ này. Nó thật có ý nghĩa. Về mảng nhờ bác tư vấn thêm dùm cho em!

 

[ngh_khanh]

Dự vào ví dụ của anh ThuNghi em cũng là 1 ví dụ này, anh ThuNghi và các AC xem nhé!
1/ Code sự kiện (Sheet2):

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Target.Address = "$D$3" Then
      Range("A7:G65000").ClearContents
      LocArr
    End If
End Sub

2/ Code thủ tục:

Sub LocArr()
Dim rngV As Range, sCode As String
Dim iR As Long, iC As Long, fR As Long
With Application
  .ScreenUpdating = False: .EnableEvents = False
End With
sCode = S2.[D3]: fR = 6
With S1
  Set rngV = .Range(.[A1], .[A65000].End(3)).Offset(1).Resize(, 8)
  With rngV
    For iR = 1 To .Rows.Count
      If rngV(iR, 4) = sCode Then
        fR = fR + 1
        S2.Cells(fR, 1).Resize(, 3) = rngV(iR, 1)
        Union(S2.Cells(fR, 1), S2.Cells(fR, 3)).NumberFormat = "dd/MM/yy"
        For iC = 5 To 8
          S2.Cells(fR, iC - 1) = rngV(iR, iC)
        Next iC
      End If
    Next iR
  End With
End With
Set rngV = Nothing
With Application
  .ScreenUpdating = True: .EnableEvents = True
End With
End Sub

 

[ndu96081631]

Dự vào ví dụ của anh ThuNghi em cũng là 1 ví dụ này, anh ThuNghi và các AC xem nhé!

Code này và code của ThuNghi cùng lắm chỉ chạy được trên file này mà thôi
Bạn nên nghiên cứu cách viết tổng quát (như tôi viết ở trên) ---> Với bất cứ dữ liệu nào, lọc bất cứ cột nào cũng chạy tuốt (chỉ cần khai sRng và Col tại sub Main là xong)
Thêm nữa: Code của bạn cũng chẳng phải là mảng gì cả nên nó sẽ cho tốc độ rất chậm ---> Nếu thế thì thà rằng dùng AutoFilter còn sướng hơn, đúng không?

 

[ngh_khanh]

Vầy được không
1> Trong Module

Sub sFilter(sRng As Range, Criteria, Col As Long, Target As Range)
Dim tmpArr, Arr, i As Long, j As Long, n As Long
On Error GoTo ExitSub
tmpArr = sRng.Value
ReDim Arr(1 To UBound(tmpArr, 1), 1 To UBound(tmpArr, 2))
For i = 1 To UBound(tmpArr, 1)
If tmpArr(i, Col) = Criteria Then
n = n + 1
For j = 1 To UBound(tmpArr, 2)
Arr(n, j) = tmpArr(i, j)
Next j
End If
Next i
Target.Resize(n, j - 1).Value = Arr
ExitSub:
End Sub

2> Trong sheet2

Private Sub Worksheet_Change(ByVal Target As Range)
Dim sRng As Range, Criteria, Col As Long
If Target.Address = "$C$1" Then
Range("A5:F60000").Clear
Set sRng = Sheet1.Range(Sheet1.[A7], Sheet1.[A65536].End(xlUp)).Resize(, 6)
Col = 2
sFilter sRng, Target.Value, Col, Range("A5")
End If
End Sub

Anh ndu ơi, bên sheet2 em chi muốn có dữ liệu ở các cột này: Ngay, Ten, sl, dg, t_tien thì phải sửa code của anh như thế nào?
Em đã tìm nhưng vẫn cho cho kết quả đúng!
Anh ndu sửa dùm em nha!

 

[ngh_khanh]

Anh ơi, em tìm mãi mà vẫn không ra chỗ sửa để dữ liệu được như ý. Anh xem dùm cho em nhé!

 

[ndu96081631]

Anh ndu ơi, bên sheet2 em chi muốn có dữ liệu ở các cột này: Ngay, Ten, sl, dg, t_tien thì phải sửa code của anh như thế nào?
Em đã tìm nhưng vẫn cho cho kết quả đúng!
Anh ndu sửa dùm em nha!

Tạm sửa thành vầy đi

Sub sFilter(sRng As Range, Criteria, Col As Long, InCol As Boolean, Target As Range)
  Dim tmpArr, Arr, i As Long, j As Long, n As Long, iC As Long
  On Error GoTo ExitSub
  tmpArr = sRng.Value
  ReDim Arr(1 To UBound(tmpArr, 1), 1 To IIf(InCol, UBound(tmpArr, 2), UBound(tmpArr, 2) - 1))
  For i = 1 To UBound(tmpArr, 1)
    iC = 1
    If tmpArr(i, Col) = Criteria Then
      n = n + 1
      For j = 1 To UBound(tmpArr, 2)
        If InCol Then
          Arr(n, iC) = tmpArr(i, j)
          iC = iC + 1
        Else
          If j <> Col Then
            Arr(n, iC) = tmpArr(i, j)
            iC = iC + 1
          End If
        End If
      Next j
    End If
  Next i
  Target.Resize(n, j - IIf(InCol, 1, 2)).Value = Arr
ExitSub:
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim sRng As Range, Criteria, Col As Long
  If Target.Address = "$C$1" Then
    Range("A5:F60000").Clear
    Set sRng = Sheet1.Range(Sheet1.[A7], Sheet1.[A65536].End(xlUp)).Resize(, 6)
    Col = 2
    [B][COLOR=red]sFilter sRng, Target.Value, Col, False, Range("A5")[/COLOR][/B]
  End If
End Sub

trong sub sFilter có thêm tham số InCol cho phép bạn chọn cột chứa Mã lọc hay không
Để ý dòng màu đỏ, nếu lấy luôn cột Mã thì
sFilter sRng, Target.Value, Col, True, Range("A5")
Nếu không lấy cột Mã thì
sFilter sRng, Target.Value, Col, False, Range("A5")
Ai đó rút gọn giùm code sFilter với (ở đoạn tùm lum IF ấy)

 

[ThuNghi]

Anh ơi, dòng này:

For iC = 3 To 5 'chi tiet

thành:

For iC = 3 To 6 'chi tiet

Bạn đã tìm ra như vậy thì vận dụng

Arr(n, 1) = tmpArr(n, 1)
      For j = 3 To UBound(tmpArr, 2)
        Arr(n, j - 1) = tmpArr(i, j)
      Next j

Nhớ là 2 arr này có số cột khác nhau
- Cột 1 =Cột 1
- Cột 3 =Cột 2