Hỏi về hàm trích dữ liệu thỏa mãn điều kiện từ sheet sang sheet khác (1 người xem)

[netvietcomputer]

Chào các a/c trên diễn đàn
Em có file dữ liệu đính kèm, trong đó trên Sheet1 có cột D chứa dữ liệu: bt; dh; qn; th
Em muốn nếu ở cột D xuất hiện "bt" thì sẽ đưa toàn bộ bản ghi đó sang sheet "BT" còn lại sẽ đưa sang sheet "Khac"
Các a/c giúp em với ạ. Em xin cảm ơn

 

[quanluu]

Chào các a/c trên diễn đàn
Em có file dữ liệu đính kèm, trong đó trên Sheet1 có cột D chứa dữ liệu: bt; dh; qn; th
Em muốn nếu ở cột D xuất hiện "bt" thì sẽ đưa toàn bộ bản ghi đó sang sheet "BT" còn lại sẽ đưa sang sheet "Khac"
Các a/c giúp em với ạ. Em xin cảm ơn

Filter và copy thui bạn, nếu bạn ko muốn làm thủ công thì ghi lại macro để dùng.

 

[giangleloi]

Chào các a/c trên diễn đàn
Em có file dữ liệu đính kèm, trong đó trên Sheet1 có cột D chứa dữ liệu: bt; dh; qn; th
Em muốn nếu ở cột D xuất hiện "bt" thì sẽ đưa toàn bộ bản ghi đó sang sheet "BT" còn lại sẽ đưa sang sheet "Khac"
Các a/c giúp em với ạ. Em xin cảm ơn

Sử dụng chức năng Advanced Filter trong trường hợp này là ngon nhất rồi, có xài code thì cũng nên theo hướng đó. Bạn hãy tìm hiểu xem, rất đơn giản mà lại nhanh chóng.

 

[netvietcomputer]

Cảm ơn các bác.
Vì em dùng để Trộn thư (Merge email) vào Word nên dùng filter nó cũng không loại trừ bản ghi khi đưa vào word ạ

 

[giangleloi]

Cảm ơn các bác.
Vì em dùng để Trộn thư (Merge email) vào Word nên dùng filter nó cũng không loại trừ bản ghi khi đưa vào word ạ

Bạn có biết Avanced Filter không (Sẽ trích lọc theo điều kiện sang 2 sheet mà bạn mong muốn)? Khác với Auto Filter nhé.Tôi nhìn file cũng biết mục đích của bạn, nên mới khuyên bạn nên làm vậy.

 

[netvietcomputer]

Bạn có biết Avanced Filter không (Sẽ trích lọc theo điều kiện sang 2 sheet mà bạn mong muốn)? Khác với Auto Filter nhé.Tôi nhìn file cũng biết mục đích của bạn, nên mới khuyên bạn nên làm vậy.

Cảm ơn bác! vừa gg thần chưởng xong. Để em thử sẽ báo lại kêt quả.

 

[netvietcomputer]

Bạn có biết Avanced Filter không (Sẽ trích lọc theo điều kiện sang 2 sheet mà bạn mong muốn)? Khác với Auto Filter nhé.Tôi nhìn file cũng biết mục đích của bạn, nên mới khuyên bạn nên làm vậy.

Như thế này thì mỗi lần cũng phải trích lọc bằng tay. cũng giống như Auto filter rồi copy dán sang thôi ạ.
Để em chuyển sang hướng macro xem
Cảm ơn bác

 

[PacificPR]

Như thế này thì mỗi lần cũng phải trích lọc bằng tay. cũng giống như Auto filter rồi copy dán sang thôi ạ.
Để em chuyển sang hướng macro xem
Cảm ơn bác

Nếu là Macro cho em góp vui tí nha

 

[giangleloi]

Như thế này thì mỗi lần cũng phải trích lọc bằng tay. cũng giống như Auto filter rồi copy dán sang thôi ạ.
Để em chuyển sang hướng macro xem
Cảm ơn bác

Muốn code thì xài cái này đi.

Sub GPE()
Dim Arr(), vlArr(), tArr(), I As Long, J As Long, K As Long, X As Long
With Sheet1
 Arr = .Range(.[A2], .[A65000].End(3)).Resize(, 27).Value
End With
ReDim vlArr(1 To UBound(Arr, 1), 1 To 27)
ReDim tArr(1 To UBound(Arr, 1), 1 To 27)
  For I = 1 To UBound(Arr, 1)
   If Arr(I, 4) <> Empty Then
    If UCase(Arr(I, 4)) = "BT" Then
      K = K + 1
      vlArr(K, 1) = K
      For J = 2 To 27
       vlArr(K, J) = Arr(I, J)
      Next J
     Else
      X = X + 1
      tArr(X, 1) = X
      For J = 2 To 27
       tArr(X, J) = Arr(I, J)
      Next J
    End If
   End If
  Next I
With Sheets("BT")
 .[A2:AA10000].ClearContents
 If K Then .[A2].Resize(K, 27) = vlArr
End With
With Sheets("Khac")
 .[A2:AA10000].ClearContents
 If X Then .[A2].Resize(X, 27) = tArr
End With
End Sub

 

[netvietcomputer]

Muốn code thì xài cái này đi.

Sub GPE()
Dim Arr(), vlArr(), tArr(), I As Long, J As Long, K As Long, X As Long
With Sheet1
 Arr = .Range(.[A2], .[A65000].End(3)).Resize(, 27).Value
End With
ReDim vlArr(1 To UBound(Arr, 1), 1 To 27)
ReDim tArr(1 To UBound(Arr, 1), 1 To 27)
  For I = 1 To UBound(Arr, 1)
   If Arr(I, 4) <> Empty Then
    If UCase(Arr(I, 4)) = "BT" Then
      K = K + 1
      vlArr(K, 1) = K
      For J = 2 To 27
       vlArr(K, J) = Arr(I, J)
      Next J
     Else
      X = X + 1
      tArr(X, 1) = X
      For J = 2 To 27
       tArr(X, J) = Arr(I, J)
      Next J
    End If
   End If
  Next I
With Sheets("BT")
 .[A2:AA10000].ClearContents
 If K Then .[A2].Resize(K, 27) = vlArr
End With
With Sheets("Khac")
 .[A2:AA10000].ClearContents
 If X Then .[A2].Resize(X, 27) = tArr
End With
End Sub

Ngon lành rồi
Em cảm ơn các bác

 

[netvietcomputer]

Muốn code thì xài cái này đi.

Sub GPE()
Dim Arr(), vlArr(), tArr(), I As Long, J As Long, K As Long, X As Long
With Sheet1
 Arr = .Range(.[A2], .[A65000].End(3)).Resize(, 27).Value
End With
ReDim vlArr(1 To UBound(Arr, 1), 1 To 27)
ReDim tArr(1 To UBound(Arr, 1), 1 To 27)
  For I = 1 To UBound(Arr, 1)
   If Arr(I, 4) <> Empty Then
    If UCase(Arr(I, 4)) = "BT" Then
      K = K + 1
      vlArr(K, 1) = K
      For J = 2 To 27
       vlArr(K, J) = Arr(I, J)
      Next J
     Else
      X = X + 1
      tArr(X, 1) = X
      For J = 2 To 27
       tArr(X, J) = Arr(I, J)
      Next J
    End If
   End If
  Next I
With Sheets("BT")
 .[A2:AA10000].ClearContents
 If K Then .[A2].Resize(K, 27) = vlArr
End With
With Sheets("Khac")
 .[A2:AA10000].ClearContents
 If X Then .[A2].Resize(X, 27) = tArr
End With
End Sub

Ngon lành rồi
Em cảm ơn các bác

 

[netvietcomputer]

Nhờ bác Fix lại hộ em cột O ạ?
Chắc do em Insert cột

 

[giangleloi]

Nhờ bác Fix lại hộ em cột O ạ?
Chắc do em Insert cột

Trong file trên bạn có xài code của tôi đâu ta. Lấy cái này thay thế:

Sub GPE()
Dim Arr(), vlArr(), tArr(), I As Long, J As Long, K As Long, X As Long
With Sheet1
 Arr = .Range(.[A2], .[A65000].End(3)).Resize(, 28).Value
End With
ReDim vlArr(1 To UBound(Arr, 1), 1 To 28)
ReDim tArr(1 To UBound(Arr, 1), 1 To 28)
  For I = 1 To UBound(Arr, 1)
   If Arr(I, 4) <> Empty Then
    If UCase(Arr(I, 4)) = "BT" Then
      K = K + 1
      vlArr(K, 1) = K
      For J = 2 To 28
       vlArr(K, J) = Arr(I, J)
      Next J
     Else
      X = X + 1
      tArr(X, 1) = X
      For J = 2 To 28
       tArr(X, J) = Arr(I, J)
      Next J
    End If
   End If
  Next I
With Sheets("BT")
 .[A2:AB10000].ClearContents
 If K Then .[A2].Resize(K, 28) = vlArr
End With
With Sheets("Khac")
 .[A2:AB10000].ClearContents
 If X Then .[A2].Resize(X, 28) = tArr
End With
End Sub

 

[quanluu]

Mình góp vui code khác vậy

Sub tach()
 Set cn = CreateObject("ADODB.Connection")
 Sheets("BT").Range("A2:AB1000").Clear
 cn.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";")
 Sheets("BT").Range("B2").CopyFromRecordset cn.Execute("Select * from [Sheet1$B2:AB" & Range("D65000").End(3).Row & "] where f3 like 'bt'")
 Sheets("BT").Range("A2:A" & Sheets("BT").Range("B65000").End(3).Row) = "=row() -1"
 Sheets("Khac").Range("A2:AB1000").Clear
 Sheets("Khac").Range("B2").CopyFromRecordset cn.Execute("Select * from [Sheet1$B2:AB" & Range("D65000").End(3).Row & "] where f3 not like 'bt'")
 Sheets("Khac").Range("A2:A" & Sheets("Khac").Range("B65000").End(3).Row) = "=row() -1"
End Sub

 

[netvietcomputer]

Nếu là Macro cho em góp vui tí nha

Nó báo lỗi bác ơi. Giúp em với ạ!
nó báo lỗi ở dòng này .Range("B2").Resize(K, 13) = dArr