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

Liên hệ QC
B

bin.vcsc

Thành viên hoạt động
Tham gia
6/12/13
Bài viết
125
Được thích
12
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.
1610352818286.png
 

File đính kèm

  • Loc va copy du lieu.xlsm
    13.8 KB · Đọc: 15
Sắp xếp theo thời gian sắp xếp theo bầu chọn
bin.vcsc đã viế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
Nhấp chuột vào đây để mở rộng...
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:
PHP: 
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
 
Upvote 0
Ba Tê đã viết:
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:
PHP: 
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
Nhấp chuột vào đây để mở rộng...
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:

Ba Tê đã viết:
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:
PHP: 
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
Nhấp chuột vào đây để mở rộng...
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?

1610360328993.png
 
Lần chỉnh sửa cuối:
Upvote 0
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
 
Upvote 0
VetMini đã viết:
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
Nhấp chuột vào đây để mở rộng...
Cám ơn bác @VetMini rất nhiều. Bin đã chạy được tệp như ý muốn.
 
Upvote 0
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.

1614933292343.png
 

File đính kèm

  • Data.xlsb
    326.1 KB · Đọc: 12
Upvote 0
bin.vcsc đã viế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.
Nhấp chuột vào đây để mở rộng...
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ỉ?
 
Upvote 0
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?
 
Upvote 0
bin.vcsc đã viết:
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?
Nhấp chuột vào đây để mở rộng...
Mã: 
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
 
Lần chỉnh sửa cuối:
Upvote 0
buiquangthuan đã viết:
Mã: 
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
Nhấp chuột vào đây để mở rộng...
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.
 
Upvote 0
bin.vcsc đã viế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.
Nhấp chuột vào đây để mở rộng...
Bẫy lỗi và thông báo:
PHP: 
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
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

NguyenNhan789556
  • Question
Viết code trong VBA
Trả lời
15
Đọc
122
SA_DQ
SA_DQ
hongphuong1997
  • Question
Lấy ký tự trong chuỗi theo nhiều điều kiện
Trả lời
12
Đọc
171
hoangtuan.net
hoangtuan.net
NguyenthiH
  • Question
Code lấy dữ liệu cho sheet!TonDau.
Trả lời
8
Đọc
185
NguyenthiH
NguyenthiH
H
HÀM NỐI CHUỖI CONCAT NHIỀU ĐIỀU KIỆN
Trả lời
0
Đọc
12
hungleanh
H
N
HÀM TÌM KIẾM CÓ ĐIỀU KIỆN
Trả lời
9
Đọc
346
hungleanh
H
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL

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

Back
Top Bottom