VBA lọc và sao chép dữ liệu từ hai bảng sau đó gom dữ liệu sang sheet mới

[bin.vcsc]

Gửi anh chị và các bạn

Mình có dữ liệu 2 bảng trong 1 sít, mình chỉ muốn lọc các dữ liệu 11 số sau đó copy sang sít mới.

Và trong trường hợp dữ liệu của bảng 1 được cập nhật thì vị trí của bảng 2 thay đổi.

Mong anh chị và các bạn giúp mình VBA để xuất được tệp như mong muốn.

Cám ơn nhiều.

 

[Ba Tê]

Gửi anh chị và các bạn

Mình có dữ liệu 2 bảng trong 1 sít, mình chỉ muốn lọc các dữ liệu 11 số sau đó copy sang sít mới.

Và trong trường hợp dữ liệu của bảng 1 được cập nhật thì vị trí của bảng 2 thay đổi.

Mong anh chị và các bạn giúp mình VBA để xuất được tệp như mong muốn.

Cám ơn nhiều.
View attachment 252796

Giải thích lòng vòng quá.
Có phải là lấy tất cả các dòng trong sheet "Data" mà trong cột A là Number có 11 chữ số sang sheet sheet "Output"?
Nếu đúng vậy thì chạy thử Sub này:

Option Explicit

Public Sub Gpe()
Dim sArr(), dArr(), I As Long, K As Long, R As Long
    sArr = Sheets("Data").Range("A3", Sheets("Data").Range("A100000").End(xlUp)).Resize(, 3).Value
    R = UBound(sArr)
ReDim dArr(1 To R, 1 To 3)
For I = 1 To R
    If Len(sArr(I, 1)) = 11 Then
        K = K + 1
        dArr(K, 1) = sArr(I, 1)
        dArr(K, 2) = sArr(I, 2)
        dArr(K, 3) = sArr(I, 3)
    End If
Next I
Sheets("Output").Range("A2:C100000").ClearContents
Sheets("Output").Range("A2").Resize(K, 3) = dArr
End Sub

 

[bin.vcsc]

Giải thích lòng vòng quá.
Có phải là lấy tất cả các dòng trong sheet "Data" mà trong cột A là Number có 11 chữ số sang sheet sheet "Output"?
Nếu đúng vậy thì chạy thử Sub này:

Option Explicit

Public Sub Gpe()
Dim sArr(), dArr(), I As Long, K As Long, R As Long
    sArr = Sheets("Data").Range("A3", Sheets("Data").Range("A100000").End(xlUp)).Resize(, 3).Value
    R = UBound(sArr)
ReDim dArr(1 To R, 1 To 3)
For I = 1 To R
    If Len(sArr(I, 1)) = 11 Then
        K = K + 1
        dArr(K, 1) = sArr(I, 1)
        dArr(K, 2) = sArr(I, 2)
        dArr(K, 3) = sArr(I, 3)
    End If
Next I
Sheets("Output").Range("A2:C100000").ClearContents
Sheets("Output").Range("A2").Resize(K, 3) = dArr
End Sub

Trời quơ! Bin làm mấy bữa nay rồi mà không sao nghĩ ra cách để làm.
Cám ơn bác @Ba Tê rất nhiều.
Cám ơn GPE một sân chơi hữu ích dành cho mọi người đam mê ếch-seo.

Bài đã được tự động gộp: 11/1/21

Giải thích lòng vòng quá.
Có phải là lấy tất cả các dòng trong sheet "Data" mà trong cột A là Number có 11 chữ số sang sheet sheet "Output"?
Nếu đúng vậy thì chạy thử Sub này:

Option Explicit

Public Sub Gpe()
Dim sArr(), dArr(), I As Long, K As Long, R As Long
    sArr = Sheets("Data").Range("A3", Sheets("Data").Range("A100000").End(xlUp)).Resize(, 3).Value
    R = UBound(sArr)
ReDim dArr(1 To R, 1 To 3)
For I = 1 To R
    If Len(sArr(I, 1)) = 11 Then
        K = K + 1
        dArr(K, 1) = sArr(I, 1)
        dArr(K, 2) = sArr(I, 2)
        dArr(K, 3) = sArr(I, 3)
    End If
Next I
Sheets("Output").Range("A2:C100000").ClearContents
Sheets("Output").Range("A2").Resize(K, 3) = dArr
End Sub

Bác @Ba Tê ơi nếu trong trường hợp số cột trong bảng của Bin đến khoảng 20 cột thì có cách nào gọn hơn không? Hay mình phải gõ đến 20 lần?

 

[VetMini]

Sửa cái chỗ này:
sArr = Sheets("Data").Range("A3", Sheets("Data").Range("A100000").End(xlUp)).Resize(, 3).Value
R = UBound(sArr)
ReDim dArr(1 To R, 1 To 3)
...
Sheets("Output").Range("A2:C100000").ClearContents
Sheets("Output").Range("A2").Resize(K, 3) = dArr

Thành:
Const SOCOT = 20
Dim j As Long
sArr = Sheets("Data").Range("A3", Sheets("Data").Range("A100000").End(xlUp)).Resize(, SOCOT).Value
For I = 1 To UBound(sArr)
If Len(sArr(I, 1)) = 11 Then
K = K + 1
For j = 1 To SOCOT
sArr(K, j) = sArr(I, j)
Next j
End If
Next I
Sheets("Output").Range("A2").Resize(100000, SOCOT).ClearContents
Sheets("Output").Range("A2").Resize(K, SOCOT) = sArr

 

[bin.vcsc]

Sửa cái chỗ này:
sArr = Sheets("Data").Range("A3", Sheets("Data").Range("A100000").End(xlUp)).Resize(, 3).Value
R = UBound(sArr)
ReDim dArr(1 To R, 1 To 3)
...
Sheets("Output").Range("A2:C100000").ClearContents
Sheets("Output").Range("A2").Resize(K, 3) = dArr

Thành:
Const SOCOT = 20
Dim j As Long
sArr = Sheets("Data").Range("A3", Sheets("Data").Range("A100000").End(xlUp)).Resize(, SOCOT).Value
For I = 1 To UBound(sArr)
If Len(sArr(I, 1)) = 11 Then
K = K + 1
For j = 1 To SOCOT
sArr(K, j) = sArr(I, j)
Next j
End If
Next I
Sheets("Output").Range("A2").Resize(100000, SOCOT).ClearContents
Sheets("Output").Range("A2").Resize(K, SOCOT) = sArr

Cám ơn bác @VetMini rất nhiều. Bin đã chạy được tệp như ý muốn.

 

[bin.vcsc]

Cám ơn bác @VetMini, đã hỗ trợ, hiện tại em nâng số lượng cột lên 45 thì báo lỗi. Bác xem giúp em với ah.

 

[Ba Tê]

Cám ơn bác @VetMini, đã hỗ trợ, hiện tại em nâng số lượng cột lên 45 thì báo lỗi. Bác xem giúp em với ah.

Lỗi là do sheets("OPRT"), từ A4 xuống cuối không có ô nào 11 ký tự.
If Len(sArr(I, 1)) = 11 Then
K = K + 1
................................
Cuối cùng K=0, lỗi!
-------------------------------
@ Trong Code bạn khai báo mảng dArr() làm gì nhỉ?

 

[bin.vcsc]

Cám ơn @Ba Tê , mình thử với dữ liệu có 11 ký tự thì tệp chạy.
Có cách nào để tệp chạy không báo lỗi không ah?

 

[BuiQuangThuan]

Cám ơn @Ba Tê , mình thử với dữ liệu có 11 ký tự thì tệp chạy.
Có cách nào để tệp chạy không báo lỗi không ah?

Public Sub Outputdata()
    Dim sArr(), dArr(), I As Long, K As Long, R As Long
    Const SOCOT = 45 'So luong cot
    Dim j As Long
    sArr = Sheets("OPRT").Range("A4", Sheets("OPRT").Range("A100000").End(xlUp)).Resize(, SOCOT).Value
    For I = 1 To UBound(sArr)
        If Len(sArr(I, 1)) = 11 Then
            K = K + 1
            For j = 1 To SOCOT
                sArr(K, j) = sArr(I, j)
            Next j
        End If
    Next I
    Sheets("Data").Range("A2").Resize(100000, SOCOT).ClearContents
    If K Then  Sheets("Data").Range("A2").Resize(K, SOCOT) = sArr
End Sub

Nếu bạn muốn nó không báo lỗi tại dòng đó thì thêm chỗ If K then..... vào coi

 

[bin.vcsc]

Public Sub Outputdata()
    Dim sArr(), dArr(), I As Long, K As Long, R As Long
    Const SOCOT = 45 'So luong cot
    Dim j As Long
    sArr = Sheets("OPRT").Range("A4", Sheets("OPRT").Range("A100000").End(xlUp)).Resize(, SOCOT).Value
    For I = 1 To UBound(sArr)
        If Len(sArr(I, 1)) = 11 Then
            K = K + 1
            For j = 1 To SOCOT
                sArr(K, j) = sArr(I, j)
            Next j
        End If
    Next I
    Sheets("Data").Range("A2").Resize(100000, SOCOT).ClearContents
    If K Then  Sheets("Data").Range("A2").Resize(K, SOCOT) = sArr
End Sub

Nếu bạn muốn nó không báo lỗi tại dòng đó thì thêm chỗ If K then..... vào coi

Cám ơn bác @buiquangthuan nhiều ah.
Nếu có lỗi này mình muốn hiện ra bảng thông báo rằng không có chuỗi 11 số trong tệp thì mình nên thêm code như thế nào cho phù hợp? Nếu bác rành xin vui lòng hướng dẫn thêm giúp mình với.
Cám ơn bác.

 

[Ba Tê]

Cám ơn bác @buiquangthuan nhiều ah.
Nếu có lỗi này mình muốn hiện ra bảng thông báo rằng không có chuỗi 11 số trong tệp thì mình nên thêm code như thế nào cho phù hợp? Nếu bác rành xin vui lòng hướng dẫn thêm giúp mình với.
Cám ơn bác.

Bẫy lỗi và thông báo:

Public Sub OutputData()
Dim sArr(), dArr(), I As Long, K As Long, J As Long, R As Long
Const SoCot = 45, Chuoi = 11 'So luong cot, so ky tu trong chuoi'
    sArr = Sheets("OPRT").Range("A4", Sheets("OPRT").Range("A100000").End(xlUp)).Resize(, SoCot).Value
    R = UBound(sArr)
    For I = 1 To R
        If Len(sArr(I, 1)) = Chuoi Then
            K = K + 1
            For J = 1 To SoCot
                sArr(K, J) = sArr(I, J)
            Next J
        End If
    Next I
With Sheets("Data")
    .Range("A2").Resize(100000, SoCot).ClearContents
    If K Then
        .Range("A2").Resize(K, SoCot) = sArr
    Else
        MsgBox "Khong co chuoi " & Chuoi & " so!", , "GPE"
    End If
End With
End Sub

 

[bin.vcsc]

Cám ơn bác @Ba Tê và Bác @buiquangthuan nhiều.