Copy và xóa dòng có điều kiện (1 người xem)

katylove83 · 21/12/14

xin chào các anh chị
em có bài này nhờ các anh chị giúp em cái.

em có 1 sheet data là sheet chưa dữ liệu con sheet2 là kết quả
em muốn sau khi chọn điều kiện tại sheet 2 tại ô J1 thì sẽ copy các dòng có chứa mã giống như tại ô J1 vào sheet 2 và sau đó xóa tất cả các dòng tại hết data có mã là = với ô J1 sheet 2.

em có đính kem file các anh chi xem file sẽ rõ hơn

cám ơn

Cá ngừ F1 · 21/12/14

katylove83 đã viết:
xin chào các anh chị
em có bài này nhờ các anh chị giúp em cái.

em có 1 sheet data là sheet chưa dữ liệu con sheet2 là kết quả
em muốn sau khi chọn điều kiện tại sheet 2 tại ô J1 thì sẽ copy các dòng có chứa mã giống như tại ô J1 vào sheet 2 và sau đó xóa tất cả các dòng tại hết data có mã là = với ô J1 sheet 2.

em có đính kem file các anh chi xem file sẽ rõ hơn

cám ơn

Dùng code advance filter nhé bạn,
tuy nhiên bạn đang pot bài nhầm box, nếu vẫn muốn dùng VBA tôi chuyển box lập trình cho bạn.
Ý 1 của bạn thì được, nhưng ý 2 mà bạn bảo xóa luôn đi thì làm sao lấy lại được dữ liệu.

katylove83 · 21/12/14

Cá ngừ F1 đã viết:
Dùng code advance filter nhé bạn,
tuy nhiên bạn đang pot bài nhầm box, nếu vẫn muốn dùng VBA tôi chuyển box lập trình cho bạn.
Ý 1 của bạn thì được, nhưng ý 2 mà bạn bảo xóa luôn đi thì làm sao lấy lại được dữ liệu.

ban ơi xoa đi rồi nhưng mà vẫn còn bên sheet 2, đến khi đó nếu chọn điều kiện khác thì sẽ copy vào dong tiếp theo co chứa dữ liệu của sheet2 ban giúp mình viết code nhé
cám ơn bạn nhiều

Cá ngừ F1 · 21/12/14

Dùng AF trường hợp này không được, vì bạn yêu cầu nhập vào ô J1, như vậy sẽ không có tiêu đề trường.
Copy đoạn code sau vào sheet Module của sheet2 xem sao:

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, [J1]) Is Nothing Then
        Dim Source(), KetQua()
        Dim i&, k&
        [B3:D1000].ClearContents
        With Sheet1
            Source = .Range(.[A2], .[C5000].End(3)).Value
        End With
        ReDim KetQua(1 To UBound(Source), 1 To 3)
        For i = 1 To UBound(Source)
            If Source(i, 1) = Target Then
                k = k + 1
                KetQua(k, 1) = Source(i, 1)
                KetQua(k, 2) = Source(i, 2)
                KetQua(k, 3) = Source(i, 3)
            End If
        Next
        [B3].Resize(i - 1, 3) = KetQua
        
    End If
End Sub

katylove83 · 21/12/14

Cá ngừ F1 đã viết:
Dùng AF trường hợp này không được, vì bạn yêu cầu nhập vào ô J1, như vậy sẽ không có tiêu đề trường.
Copy đoạn code sau vào sheet Module của sheet2 xem sao:

Mã:

Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, [J1]) Is Nothing Then Dim Source(), KetQua() Dim i&, k& [B3:D1000].ClearContents With Sheet1 Source = .Range(.[A2], .[C5000].End(3)).Value End With ReDim KetQua(1 To UBound(Source), 1 To 3) For i = 1 To UBound(Source) If Source(i, 1) = Target Then k = k + 1 KetQua(k, 1) = Source(i, 1) KetQua(k, 2) = Source(i, 2) KetQua(k, 3) = Source(i, 3) End If Next [B3].Resize(i - 1, 3) = KetQua End If End Sub

[/Qd
bạn ơi mình muốn dữ liệu khi copy qua sheet 2 sẽ giữ nguyên luôn chứ không có xóa đi và khi chọn mã khác thì dữ liệu sẽ vẫn tiếp tục copy qua sheet 2 dong tiếp theo và dữ liệu tại sheet data sẽ xóa đi mã đó luôn nhé
nhờ bạn xem lại giúp

Cá ngừ F1 · 21/12/14

Tôi thấy yêu cầu hơi lạ.
nếu giả sử lúc đầu chọn L1, nó copy rôi, xong bạn chọn mã khác, roi chọn lại L1 thì sao?co copy tiep ko?

katylove83 · 21/12/14

Cá ngừ F1 đã viết:
Tôi thấy yêu cầu hơi lạ.
nếu giả sử lúc đầu chọn L1, nó copy rôi, xong bạn chọn mã khác, roi chọn lại L1 thì sao?co copy tiep ko?

tất nhiên là khi copy L1 xong rồi thì đã xóa bên sheet data lúc này ko còn L1 nữa vậy nên lúc chọn L1 tiếp thì cũng đâu có gì mà copy nữa đâu bạn, lúc đó chọn tiếp L khác thôi bạn ah, dữ liệu L1 nó lúc đó vẫn nằm tại sheet 2 mà
nội chung chẳng qua là trước lúc xóa dữ liệu thì mình copy lưu lại thôi

Quang_Hải · 21/12/14

Cá ngừ F1 đã viết:
Tôi thấy yêu cầu hơi lạ.
nếu giả sử lúc đầu chọn L1, nó copy rôi, xong bạn chọn mã khác, roi chọn lại L1 thì sao?co copy tiep ko?

Lạ gì chứ, người ta muốn vậy mà. Mai mốt vô chùa tự nhiên hỏi sao sư phụ lại cạo trọc thì bị đòn ráng chịu.
Code bài này kiểu kỳ cục nè. Thằng kq thì trả về nguồn, thằng nguồn thì đem vô kq

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> [J1].Address Then End
Application.EnableEvents = False
Dim arr(), kq(), i, j, k, x
With Sheet1
   arr = .Range("A2", .[C65536].End(3)).Value
End With
ReDim kq(1 To UBound(arr), 1 To 3)
For i = 1 To UBound(arr)
   If arr(i, 1) = Target Then
      k = k + 1
      For j = 1 To 3
         arr(k, j) = arr(i, j)
      Next
   Else
      x = x + 1
      For j = 1 To 3
         kq(x, j) = arr(i, j)
      Next
   End If
Next
Sheet1.[A2].Resize(i - 1, 3) = kq
If k Then Sheet2.[B65536].End(3)(2).Resize(k, 3) = arr
Application.EnableEvents = True
End Sub

katylove83 đã viết:
vậy bác giúp em với, cám ơn bác hải nhiều

Xem code bài 8. Mới bổ sung code. Nhiều bài thừa quá, MOD có đi ngang xoá bớt dùm.

katylove83 · 21/12/14

quanghai1969 đã viết:
Lạ gì chứ, người ta muốn vậy mà. Mai mốt vô chùa tự nhiên hỏi sao sư phụ lại cạo trọc thì bị đòn ráng chịu.

vậy bác giúp em với, cám ơn bác hải nhiều

quanghai1969 đã viết:
Lạ gì chứ, người ta muốn vậy mà. Mai mốt vô chùa tự nhiên hỏi sao sư phụ lại cạo trọc thì bị đòn ráng chịu.
Code bài này kiểu kỳ cục nè. Thằng kq thì trả về nguồn, thằng nguồn thì đem vô kq

PHP:

Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> [J1].Address Then End Application.EnableEvents = False Dim arr(), kq(), i, j, k, x With Sheet1 arr = .Range("A2", .[C65536].End(3)).Value End With ReDim kq(1 To UBound(arr), 1 To 3) For i = 1 To UBound(arr) If arr(i, 1) = Target Then k = k + 1 For j = 1 To 3 arr(k, j) = arr(i, j) Next Else x = x + 1 For j = 1 To 3 kq(x, j) = arr(i, j) Next End If Next Sheet1.[A2].Resize(i - 1, 3) = kq If k Then Sheet2.[B65536].End(3)(2).Resize(k, 3) = arr Application.EnableEvents = True End Sub

chuẩn luôn bác hải ơi, thank back, mà mod là gì vậy bác

Hau151978 · 21/12/14

katylove83 đã viết:
xin chào các anh chị
em có bài này nhờ các anh chị giúp em cái.

em có 1 sheet data là sheet chưa dữ liệu con sheet2 là kết quả
em muốn sau khi chọn điều kiện tại sheet 2 tại ô J1 thì sẽ copy các dòng có chứa mã giống như tại ô J1 vào sheet 2 và sau đó xóa tất cả các dòng tại hết data có mã là = với ô J1 sheet 2.

em có đính kem file các anh chi xem file sẽ rõ hơn

cám ơn

Thêm cách nữa cho bạn này, đặt sub này trong code của sheet2.

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim n&
    Application.EnableEvents = False
        If Target.Address = "$J$1" Then
            n = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
            On Error GoTo thoat
            Sheet1.Range("A1:C" & n).AutoFilter 1, Target.Text
            If Sheet1.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
                With Sheet1.Range("A2:C" & n).SpecialCells(xlCellTypeVisible)
                    .Copy Range("B" & (Range("B" & Rows.Count).End(xlUp).Row + 1))
                    .EntireRow.Delete
                End With
            End If
thoat:
            Sheet1.AutoFilterMode = False
        End If
    Application.EnableEvents = True
End Sub

katylove83 · 21/12/14

Hau151978 đã viết:

Thêm cách nữa cho bạn này, đặt sub này trong code của sheet2.

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim n&
    Application.EnableEvents = False
        If Target.Address = "$J$1" Then
            n = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
            On Error GoTo thoat
            Sheet1.Range("A1:C" & n).AutoFilter 1, Target.Text
            If Sheet1.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
                With Sheet1.Range("A2:C" & n).SpecialCells(xlCellTypeVisible)
                    .Copy Range("B" & (Range("B" & Rows.Count).End(xlUp).Row + 1))
                    .EntireRow.Delete
                End With
            End If
thoat:
            Sheet1.AutoFilterMode = False
        End If
    Application.EnableEvents = True
End Sub

xin chân thành sự nhiệt tình giúp đỡ của các bác

Quang_Hải · 22/12/14

Thêm 1 cách, ngắn thêm tẹo. Cạnh tranh với bài 10.

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> [J1].Address Then End
Application.EnableEvents = False
Dim Rng As Range
Set Rng = Sheet1.[A1].CurrentRegion
Rng.AutoFilter 1, Target
Rng.Offset(1).Copy [B65536].End(3)(2)
Rng.Offset(1).EntireRow.Delete
Rng.AutoFilter
Application.EnableEvents = True
End Sub

hngiatuong · 21/5/15

quanghai1969 đã viết:
Thêm 1 cách, ngắn thêm tẹo. Cạnh tranh với bài 10.

PHP:

Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> [J1].Address Then End Application.EnableEvents = False Dim Rng As Range Set Rng = Sheet1.[A1].CurrentRegion Rng.AutoFilter 1, Target Rng.Offset(1).Copy [B65536].End(3)(2) Rng.Offset(1).EntireRow.Delete Rng.AutoFilter Application.EnableEvents = True End Sub

Ở đây khi cột A thỏa mãn J1 thì copy, nhưng em muốn cột B thỏa mãn J1 thì phải sửa lại thế nào. Em loay hoay sửa mãi không được.

phamhahnm · 22/5/15

hngiatuong đã viết:
Ở đây khi cột A thỏa mãn J1 thì copy, nhưng em muốn cột B thỏa mãn J1 thì phải sửa lại thế nào. Em loay hoay sửa mãi không được.

Em cũng đang cần cái này. Anh nào giúp em với.

hngiatuong · 22/5/15

hngiatuong đã viết:
Ở đây khi cột A thỏa mãn J1 thì copy, nhưng em muốn cột B thỏa mãn J1 thì phải sửa lại thế nào. Em loay hoay sửa mãi không được.

Vấn đề này em đã sửa được rồi.

Copy và xóa dòng có điều kiện (1 người xem)

Người dùng đang xem chủ đề này

katylove83

Thành viên hoạt động

File đính kèm

Cá ngừ F1

( ͡° ͜ʖ ͡°)

katylove83

Thành viên hoạt động

Cá ngừ F1

( ͡° ͜ʖ ͡°)

katylove83

Thành viên hoạt động

Cá ngừ F1

( ͡° ͜ʖ ͡°)

katylove83

Thành viên hoạt động

Quang_Hải

Thành viên gạo cội

katylove83

Thành viên hoạt động

Hau151978

Thành viên tích cực

katylove83

Thành viên hoạt động

Quang_Hải

Thành viên gạo cội

hngiatuong

CMC

phamhahnm

Thành viên mới

hngiatuong

CMC

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Thời gian đếm ngược.