Nhờ viết code VBA tách bẳng dữ liệu có điều kiện

chidung2009 · 12/6/20

Khi nhập liệu ngày vào ô I2 hoặc I3 thì sẽ tự động tách dữ liệu từ bảng B6 : I999 giống như bảng L6 : S999 với điều kiện lọc theo cột A ( có công thức);
Nếu cột A hiện số thứ tự thì lấy dữ liệu và ngược lại;
Đồng thời sẽ lấy dữ liệu ở cột A làm số thứ tự cho bảng L6 : S999.
Trong trường hợp nếu cột A không có dữ liệu nào thỏa mãn điều kiện thì không thực hiện lệnh tách dữ liệu (kể cả tiêu đề)
Lưu ý: khi tách bảng chỉ copy dữ liệu chứ không copy công thức, thộc tính của bảng B6 : I999

Mình rất mong được sự giúp đỡ của GPE và xin chân thành cảm ơn

phulien1902 · 12/6/20

Bạn thử:

PHP:

Sub Test()
    Dim a(), b(), i&, k%, LR, j%, BD, KT
    With Sheet1
        a = .Range("B7", .Range("B65000").End(3)).Resize(, 8).Value
        LR = UBound(a)
    End With
    BD = Sheet1.Range("I2").Value2: KT = Sheet1.Range("I3").Value2
    ReDim b(1 To LR, 1 To 8)
    With Sheet1
        For i = 1 To LR
            If a(i, 2) >= BD And a(i, 2) <= KT Then
                k = k + 1: b(k, 1) = k
                For j = 2 To 8
                    b(k, j) = a(i, j)
                Next j
            End If
        Next i
        Sheet1.Range("L7:S5000").ClearContents
        If k Then
            With Sheet1
                .Range("L7").Resize(k, 8) = b
            End With
        End If
    End With
End Sub

chidung2009 · 12/6/20

phulien1902 đã viết:

Bạn thử:

PHP:

Sub Test()
    Dim a(), b(), i&, k%, LR, j%, BD, KT
    With Sheet1
        a = .Range("B7", .Range("B65000").End(3)).Resize(, 8).Value
        LR = UBound(a)
    End With
    BD = Sheet1.Range("I2").Value2: KT = Sheet1.Range("I3").Value2
    ReDim b(1 To LR, 1 To 8)
    With Sheet1
        For i = 1 To LR
            If a(i, 2) >= BD And a(i, 2) <= KT Then
                k = k + 1: b(k, 1) = k
                For j = 2 To 8
                    b(k, j) = a(i, j)
                Next j
            End If
        Next i
        Sheet1.Range("L7:S5000").ClearContents
        If k Then
            With Sheet1
                .Range("L7").Resize(k, 8) = b
            End With
        End If
    End With
End Sub

Mình đã thử code vba của bạn nhưng nó chỉ tách được 3 hàng sau, hàng thứ 4 ( STT 3 - hàng B9) nó không có dữ liệu sau khi tách

befaint · 12/6/20

Code chay.. mình tự chỉnh nếu chưa được nhá

PHP:

Option explicit
Sub vidu()
const scol_ref ="C"
const start_row = 7
const rng_header = "B6:I6"
const scell_date_start = "I2"
const scell_date_end = "I3"
const scell_target = "L6"
const num_cols = 8
Dim last_row as long, data as variant, ub2 as long, i as long, ddate as long
Dim res as variant, ii as long, j as long
Dim date_start as long, date_end as long
with sheet1
'xoa du lieu cu'
.range(scell_target).resize(1048500, num_cols ).clearcontents
last_row =.range(scol_ref & rows.count).end(xlup).row
if last_row < start_row then
msgbox "khong co du lieu"
end
end if
data =.range(scol_ref & start_row  ).resize(last_row - start_row + 1, num_cols -1).value2
date_start = val(.range(scell_date_start ).value2)
date_end = val(.range(scell_date_end ).value2)
end with
last_row = ubound(data,1)
ub2=ubound(data,2)
Redim res(1 to last_row, 1 to num_cols)
For i=2 to last_row
ddate = data(i,4)
if ddate = 0 then
ii = ii+1
res(ii,1)=ii
for j=1 to ub2
res(ii, j+1) = data(i,j)
next j
elseif ddate >= date_start  and ddate <= date_end then
ii = ii+1
res(ii,1)=ii
for j=1 to ub2
res(ii, j+1) = data(i,j)
next j
End if
Next i
'ghi ket qua
if ii>0 then
sheet1.range(scell_target).resize(1,num_cols).value = sheet1.range(rng_header ).value2
sheet1.range(scell_target).offset(1,0).resize(ii,num_cols).value=res
end if
end sub

Ba Tê · 12/6/20

chidung2009 đã viết:
Khi nhập liệu ngày vào ô I2 hoặc I3 thì sẽ tự động tách dữ liệu từ bảng B6 : I999 giống như bảng L6 : S999 với điều kiện lọc theo cột A ( có công thức);
Nếu cột A hiện số thứ tự thì lấy dữ liệu và ngược lại;
Đồng thời sẽ lấy dữ liệu ở cột A làm số thứ tự cho bảng L6 : S999.
Trong trường hợp nếu cột A không có dữ liệu nào thỏa mãn điều kiện thì không thực hiện lệnh tách dữ liệu (kể cả tiêu đề)
Lưu ý: khi tách bảng chỉ copy dữ liệu chứ không copy công thức, thộc tính của bảng B6 : I999
View attachment 239179

Mình rất mong được sự giúp đỡ của GPE và xin chân thành cảm ơn

Đã dùng VBA còn xài chi công thức cột A?
Chạy thử Sub này coi sao (Đã sửa code)

PHP:

Public Sub s_Gpe()
Dim sArr(), dArr(), I As Long, J As Long, K As Long, R As Long, fDay As Long, eDay As Long
    sArr = Range("B7", Range("B10000").End(xlUp)).Resize(, 8).Value
    R = UBound(sArr)
ReDim dArr(1 To R, 1 To 8)
    fDay = Range("I2").Value
    eDay = Range("I3").Value
    For I = 1 To R
        If sArr(I, 5) = Empty Or (sArr(I, 5) >= fDay And sArr(I, 5) <= eDay) Then
            K = K + 1
            dArr(K, 1) = K
            For J = 2 To 8
                dArr(K, J) = sArr(I, J)
            Next J
        End If
    Next I
Range("L6").Resize(1000, 8).ClearContents
If K Then
    Range("L6").Resize(, 8).Value = Range("B6").Resize(, 8).Value
    Range("L7").Resize(K, 8) = dArr
Else
    MsgBox "Khong co du lieu!", , "GPE"
End If
End Sub

phulien1902 · 12/6/20

chidung2009 đã viết:
Mình đã thử code vba của bạn nhưng nó chỉ tách được 3 hàng sau, hàng thứ 4 ( STT 3 - hàng B9) nó không có dữ liệu sau khi tách

Mình nhầm cột lọc, code của bác Ba tê chuẩn cho bạn rồi đấy.
Code bài #2, bạn thay:

PHP:

If a(i, 2) >= BD And a(i, 2) <= KT Then

bằng:

PHP:

 If a(I, 5) = Empty Or a(I, 5) >= BD And a(I, 5) <= KT Then

chidung2009 · 12/6/20

Ba Tê đã viết:

Đã dùng VBA còn xài chi công thức cột A?
Chạy thử Sub này coi sao (Đã sửa code)

PHP:

Public Sub s_Gpe()
Dim sArr(), dArr(), I As Long, J As Long, K As Long, R As Long, fDay As Long, eDay As Long
    sArr = Range("B7", Range("B10000").End(xlUp)).Resize(, 8).Value
    R = UBound(sArr)
ReDim dArr(1 To R, 1 To 8)
    fDay = Range("I2").Value
    eDay = Range("I3").Value
    For I = 1 To R
        If sArr(I, 5) = Empty Or (sArr(I, 5) >= fDay And sArr(I, 5) <= eDay) Then
            K = K + 1
            dArr(K, 1) = K
            For J = 2 To 8
                dArr(K, J) = sArr(I, J)
            Next J
        End If
    Next I
Range("L6").Resize(1000, 8).ClearContents
If K Then
    Range("L6").Resize(, 8).Value = Range("B6").Resize(, 8).Value
    Range("L7").Resize(K, 8) = dArr
Else
    MsgBox "Khong co du lieu!", , "GPE"
End If
End Sub

Code của bạn rất hay, mình xin chân thành cảm ơn
Cho mình hỏi thêm.
If sArr(I, 5) = Empty Or (sArr(I, 5) >= fDay And sArr(I, 5) <= eDay) Then

trong đó 5 có ý nghĩa là gì

Bài đã được tự động gộp: 12/6/20

phulien1902 đã viết:
Mình nhầm cột lọc, code của bác Ba tê chuẩn cho bạn rồi đấy.
Code bài #2, bạn thay:

PHP:

If a(i, 2) >= BD And a(i, 2) <= KT Then

bằng:

PHP:

If a(I, 5) = Empty Or a(I, 5) >= BD And a(I, 5) <= KT Then

Mình đã thử nghiệm và đúng như yêu cầu của mình.
Mình rất vui và cảm ơn bạn đã giúp đỡ

chidung2009 · 12/6/20

Mình cảm ơn

ndu96081631 · 12/6/20

chidung2009 đã viết:
Vậy công thức =IF(OR(AND(C7>=$I$2,C7<=$I$3),AND(C7<=$I$3,F7=""),AND(F7>$I$3,C7<=$I$2),AND(F7>=$I$2,F7<=$I$3)),MAX($A$5:A6)+1,"")
thì viết lại như thế nào
Mình xin lỗi đã làm phiên các anh chị GPE

Lấy công thức của bạn làm điều kiện lọc cho Advanced Filter là đơn giản nhất, chắc chỉ vài dòng code là xong

HieuCD · 12/6/20

chidung2009 đã viết:
Khi nhập liệu ngày vào ô I2 hoặc I3 thì sẽ tự động tách dữ liệu từ bảng B6 : I999 giống như bảng L6 : S999 với điều kiện lọc theo cột A ( có công thức);
Nếu cột A hiện số thứ tự thì lấy dữ liệu và ngược lại;
Đồng thời sẽ lấy dữ liệu ở cột A làm số thứ tự cho bảng L6 : S999.
Trong trường hợp nếu cột A không có dữ liệu nào thỏa mãn điều kiện thì không thực hiện lệnh tách dữ liệu (kể cả tiêu đề)
Lưu ý: khi tách bảng chỉ copy dữ liệu chứ không copy công thức, thộc tính của bảng B6 : I999
View attachment 239179

Mình rất mong được sự giúp đỡ của GPE và xin chân thành cảm ơn

Tạo cho bạn công thức tự trích dữ liệu, khi thấy yêu cầu copy bạn copy dòng cuối xuống dưới

chidung2009 · 12/6/20

Ba Tê đã viết:

Đã dùng VBA còn xài chi công thức cột A?
Chạy thử Sub này coi sao (Đã sửa code)

PHP:

Public Sub s_Gpe()
Dim sArr(), dArr(), I As Long, J As Long, K As Long, R As Long, fDay As Long, eDay As Long
    sArr = Range("B7", Range("B10000").End(xlUp)).Resize(, 8).Value
    R = UBound(sArr)
ReDim dArr(1 To R, 1 To 8)
    fDay = Range("I2").Value
    eDay = Range("I3").Value
    For I = 1 To R
        If sArr(I, 5) = Empty Or (sArr(I, 5) >= fDay And sArr(I, 5) <= eDay) Then
            K = K + 1
            dArr(K, 1) = K
            For J = 2 To 8
                dArr(K, J) = sArr(I, J)
            Next J
        End If
    Next I
Range("L6").Resize(1000, 8).ClearContents
If K Then
    Range("L6").Resize(, 8).Value = Range("B6").Resize(, 8).Value
    Range("L7").Resize(K, 8) = dArr
Else
    MsgBox "Khong co du lieu!", , "GPE"
End If
End Sub

Sau khi chạy thử nghiệm code của anh , đối với dữ liệu ít thì rất ngon, nhưng khi thử nghiệm bảng với dữ liệu khoảng 1.000 dòng thì chạy rất chậm. Nên xét điều kiện ở A để lọc dữ liệu vừa nhanh mà khả quan nhất
Mong anh hỗ trợ viết code giúp em với
Em cảm ơn anh nhiều

Bài đã được tự động gộp: 12/6/20

HieuCD đã viết:
Tạo cho bạn công thức tự trích dữ liệu, khi thấy yêu cầu copy bạn copy dòng cuối xuống dưới

Phương pháp của bạn chỉ hữu dụng đối với bảng ít dữ liệu, trong trường hợp bảng dữ liệu trên 10.000 dòng thì file rất nặng và chạy chậm
Mình cảm ơn bạn đã giúp đỡ

Phuocam · 12/6/20

chidung2009 đã viết:
Sau khi chạy thử nghiệm code của anh , đối với dữ liệu ít thì rất ngon, nhưng khi thử nghiệm bảng với dữ liệu khoảng 1.000 dòng thì chạy rất chậm. Nên xét điều kiện ở A để lọc dữ liệu vừa nhanh mà khả quan nhất
Mong anh hỗ trợ viết code giúp em với
Em cảm ơn anh nhiều
....
Phương pháp của bạn chỉ hữu dụng đối với bảng ít dữ liệu, trong trường hợp bảng dữ liệu trên 10.000 dòng thì file rất nặng và chạy chậm
Mình cảm ơn bạn đã giúp đỡ

Chào bạn;
Với dữ liệu 1000 dòng bạn chạy code của anh Ba Tê bao nhiêu giây?

befaint · 12/6/20

Chắc chắn code bài #4 chạy nhanh hơn

chidung2009 · 12/6/20

phuocam đã viết:
Chào bạn;
Với dữ liệu 1000 dòng bạn chạy code của anh Ba Tê bao nhiêu giây?

Do mình nhập sửa code bị sai nên nó mới bị lỗi Vòng lặp vô tận

Phuocam · 12/6/20

Dùng Advanced Filter, điều kiện là:

=OR(F7="",AND(F7>=$I$2,F7<=$I$3))

.

Phuocam · 12/6/20

... .

Nhờ viết code VBA tách bẳng dữ liệu có điều kiện

chidung2009

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

File đính kèm

phulien1902

GPE - My love

chidung2009

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

File đính kèm

befaint

|||||||||||||

Ba Tê

Cạo Rồi Khỏi Gội

phulien1902

GPE - My love

chidung2009

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

chidung2009

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

ndu96081631

Huyền thoại GPE

HieuCD

Chuyên gia GPE

File đính kèm

chidung2009

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

Phuocam

Thành viên mới

befaint

|||||||||||||

chidung2009

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

Phuocam

Thành viên mới

Phuocam

Thành viên mới

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