Nhờ giúp em: Code VBA lọc số liệu của sổ tài sản và từ ngày đến ngày?

[hitlecp]

Chào anh, chị
Nhờ anh, chị giúp em code VBA để lọc số liệu của sổ tài sản theo từng POP và từ ngày đến ngày, vì nguồn dữ liệu ở sheet FA0202 em kết xuất từ chương trình xuống rất lớn khoảng vài trăm ngàn dòng nếu làm công thức thì file chạy không nổi. Nên nhờ anh, chị giúp em code để chạy ạ (em có đính kèm file).
Em cám ơn!

 

[SA_DQ]

Bạn xài macro sự kiện này tại trang tính 'Loc_. . .' của bạn:

Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, [B3]) Is Nothing Then
    Dim Rws As Long, J As Long, W As Integer, Col As Integer
    Dim Arr()
    With Sheets("FA0202")
        Rws = .[A1000000].End(xlUp).Row
        Arr() = .[A8].Resize(Rws, 16).Value
        ReDim KQ(1 To Rws, 1 To 14)
        [B7].CurrentRegion.Offset(1).ClearContents
        For J = 1 To UBound(Arr())
            If Arr(J, 16) = Target.Value Then
                If Arr(J, 7) >= Target.Offset(1).Value And Arr(J, 7) <= Target.Offset(2).Value Then
                    W = W + 1
                    For Col = 1 To 14
                        KQ(W, Col) = Arr(J, Col)
                    Next Col
                End If
            End If
        Next J
        [A8].Resize(W, 14).Value = KQ()
    End With
 End If
End Sub

& chúc thành công!

 

[hitlecp]

Bạn xài macro sự kiện này tại trang tính 'Loc_. . .' của bạn:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [B3]) Is Nothing Then
    Dim Rws As Long, J As Long, W As Integer, Col As Integer
    Dim Arr()
    With Sheets("FA0202")
        Rws = .[A1000000].End(xlUp).Row
        Arr() = .[A8].Resize(Rws, 16).Value
        ReDim KQ(1 To Rws, 1 To 14)
        [B7].CurrentRegion.Offset(1).ClearContents
        For J = 1 To UBound(Arr())
            If Arr(J, 16) = Target.Value Then
                If Arr(J, 7) >= Target.Offset(1).Value And Arr(J, 7) <= Target.Offset(2).Value Then
                    W = W + 1
                    For Col = 1 To 14
                        KQ(W, Col) = Arr(J, Col)
                    Next Col
                End If
            End If
        Next J
        [A8].Resize(W, 14).Value = KQ()
    End With
End If
End Sub

& chúc thành công!

- Trường hợp nếu nhập từ ngày đến ngày không có ở bên sheet FA0202 thì macro sự kiện lại báo lỗi này, chỉnh lại sao ạ.
- Trường hợp nếu dữ liệu bên sheet FA0202 không có thì kết quả không hiện lên được không anh
Nhờ anh chỉ giúp em với. Em cám ơn!

 

[HieuCD]

Chào anh, chị
Nhờ anh, chị giúp em code VBA để lọc số liệu của sổ tài sản theo từng POP và từ ngày đến ngày, vì nguồn dữ liệu ở sheet FA0202 em kết xuất từ chương trình xuống rất lớn khoảng vài trăm ngàn dòng nếu làm công thức thì file chạy không nổi. Nên nhờ anh, chị giúp em code để chạy ạ (em có đính kèm file).
Em cám ơn!

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim sArr(), Res(), POP$, fDay, eDay
  Dim sRow&, i&, k&, j&
 
  If Target.Count = 1 Then
    If Not Intersect(Target, Range("B3:B5")) Is Nothing Then
      Range("B7").CurrentRegion.Offset(1).ClearContents
      POP = Range("B3").Value
      If POP = Empty Then Exit Sub
      fDay = Range("B4").Value: eDay = Range("B5").Value
      If fDay = Empty Then fDay = DateValue("1918/1/1")
      If eDay = Empty Then eDay = DateValue("2100/1/1")
      If IsDate(fDay) And IsDate(eDay) Then
        With Sheets("FA0202")
          i = .Range("A" & Rows.Count).End(xlUp).Row
          If i < 8 Then MsgBox ("Khong co du lieu"): Exit Sub
          sArr = .Range("A8:P" & i).Value
        End With
        sRow = UBound(sArr)
        ReDim Res(1 To sRow, 1 To 14)
        For i = 1 To sRow
          If sArr(i, 16) = POP Then
            If sArr(i, 7) >= fDay And sArr(i, 7) <= eDay Then
              k = k + 1
              For j = 1 To 14
                Res(k, j) = sArr(i, j)
              Next j
            End If
          End If
        Next i
        If k Then Range("A8").Resize(k, 14).Value = Res()
      End If
    End If
  End If
End Sub

 

[hitlecp]

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim sArr(), Res(), POP$, fDay, eDay
  Dim sRow&, i&, k&, j&

  If Target.Count = 1 Then
    If Not Intersect(Target, Range("B3:B5")) Is Nothing Then
      Range("B7").CurrentRegion.Offset(1).ClearContents
      POP = Range("B3").Value
      If POP = Empty Then Exit Sub
      fDay = Range("B4").Value: eDay = Range("B5").Value
      If fDay = Empty Then fDay = DateValue("1918/1/1")
      If eDay = Empty Then eDay = DateValue("2100/1/1")
      If IsDate(fDay) And IsDate(eDay) Then
        With Sheets("FA0202")
          i = .Range("A" & Rows.Count).End(xlUp).Row
          If i < 8 Then MsgBox ("Khong co du lieu"): Exit Sub
          sArr = .Range("A8:P" & i).Value
        End With
        sRow = UBound(sArr)
        ReDim Res(1 To sRow, 1 To 14)
        For i = 1 To sRow
          If sArr(i, 16) = POP Then
            If sArr(i, 7) >= fDay And sArr(i, 7) <= eDay Then
              k = k + 1
              For j = 1 To 14
                Res(k, j) = sArr(i, j)
              Next j
            End If
          End If
        Next i
        If k Then Range("A8").Resize(k, 14).Value = Res()
      End If
    End If
  End If
End Sub

Dạ, em cám ơn nhiều ạ

 

[Ba Tê]

Dữ liệu vài trăm ngàn dòng mà vẫn cần công thức 2 cột O, P sheet FA... ?