Lọc và copy dữ liệu

[Sơn Mã]

Mình có bảng dữ liệu ở sheet(DULIEU):
- Cột G chứa các dữ liệu cần copy.
- Các cột tiếp theo có chứa dữ liệu ở các ô bất kì từ dòng 5 trở đi.
- Mong các bạn giúp copy như sau:
1/ Lọc dữ liệu cột H: tích bỏ dấu ô Blanks
2/ Copy dữ liệu ở cột G
3/ Dán dữ liệu copy ở cột G vào cột H tương ứng ở sheet(KETQUA)
- Cứ tuần tự làm như vậy cho các cột tiếp theo cho đến hết cột dữ liệu.
- Mình làm thủ công với file hơn 1000 cột nên rất lâu. Mong GPE và các bạn xem giúp. Xin cảm ơn nhiều!

 

[Ba Tê]

Mình có bảng dữ liệu ở sheet(DULIEU):
- Cột G chứa các dữ liệu cần copy.
- Các cột tiếp theo có chứa dữ liệu ở các ô bất kì từ dòng 5 trở đi.
- Mong các bạn giúp copy như sau:
1/ Lọc dữ liệu cột H: tích bỏ dấu ô Blanks
2/ Copy dữ liệu ở cột G
3/ Dán dữ liệu copy ở cột G vào cột H tương ứng ở sheet(KETQUA)
- Cứ tuần tự làm như vậy cho các cột tiếp theo cho đến hết cột dữ liệu.
- Mình làm thủ công với file hơn 1000 cột nên rất lâu. Mong GPE và các bạn xem giúp. Xin cảm ơn nhiều!

Bạn chạy thử Sub này coi sao nhé.
1000 cột thì thay Col=25 bằng Col=1000

Public Sub GPE()
Dim sArr(), dArr(), I As Long, J As Long, K As Long, C As Long, Col As Long, R As Long
Col = 25 '<----------------------------So cot DULIEU'
With Sheets("DULIEU")
    sArr = .Range("G5", .Range("G5").End(xlDown)).Resize(, Col).Value
    R = UBound(sArr)
    ReDim dArr(1 To R, 1 To Col - 1)
End With
For J = 2 To Col
    K = 0: C = C + 1
    For I = 1 To R
        If sArr(I, J) <> Empty Then
            K = K + 1
            dArr(K, C) = sArr(I, 1)
        End If
    Next I
Next J
Sheets("KETQUA").Range("H5").Resize(R, Col - 1) = dArr
End Sub

 

[Sơn Mã]

Bạn chạy thử Sub này coi sao nhé.
1000 cột thì thay Col=25 bằng Col=1000

Public Sub GPE()
Dim sArr(), dArr(), I As Long, J As Long, K As Long, C As Long, Col As Long, R As Long
Col = 25 '<----------------------------So cot DULIEU'
With Sheets("DULIEU")
    sArr = .Range("G5", .Range("G5").End(xlDown)).Resize(, Col).Value
    R = UBound(sArr)
    ReDim dArr(1 To R, 1 To Col - 1)
End With
For J = 2 To Col
    K = 0: C = C + 1
    For I = 1 To R
        If sArr(I, J) <> Empty Then
            K = K + 1
            dArr(K, C) = sArr(I, 1)
        End If
    Next I
Next J
Sheets("KETQUA").Range("H5").Resize(R, Col - 1) = dArr
End Sub

Vâng, đúng như thế rồi ạ. Nhưng khi mình kiểm tra thấy có cột không copy dữ liệu. Mong bạn xem giúp trong trường hợp này ở cột M. Xin cảm ơn rất nhiều!

 

[Ba Tê]

Vâng, đúng như thế rồi ạ. Nhưng khi mình kiểm tra thấy có cột không copy dữ liệu. Mong bạn xem giúp trong trường hợp này ở cột M. Xin cảm ơn rất nhiều!

Cột G sheet DULIEU từ dòng 5 xuống không liên tục. Cụ thể đến dòng 3244 là đứt quãng.
Dữ liệu cột G không được đứt quãng trong code này.

 

[Sơn Mã]

Cột G sheet DULIEU từ dòng 5 xuống không liên tục. Cụ thể đến dòng 3244 là đứt quãng.
Dữ liệu cột G không được đứt quãng trong code này.

Dạ, vâng. Đúng rồi ạ. Xin cảm ơn rất nhiều!

 

[Sơn Mã]

Cột G sheet DULIEU từ dòng 5 xuống không liên tục. Cụ thể đến dòng 3244 là đứt quãng.
Dữ liệu cột G không được đứt quãng trong code này.

Bạn ơi. Trong trường hợp này cột Y, Z khi mình copy như vậy cũng không có dữ liệu ạ. Mặc dù cột G có các dữ liệu liên tục! Mong bạn xem giúp. Xin cảm ơn ạ!

 

[Ba Tê]

Bạn ơi. Trong trường hợp này cột Y, Z khi mình copy như vậy cũng không có dữ liệu ạ. Mặc dù cột G có các dữ liệu liên tục! Mong bạn xem giúp. Xin cảm ơn ạ!

Vì dữ liệu = 0, Bạn tìm dòng này:

If sArr(I, J) <> Empty Then

Thay bằng:

If sArr(I, J) <> "" Then

Chú ý là DULIEU từ cột G đến cột AF là 26 cột,
Bạn phải sửa lại 25 thành 26 trong dòng này:

Col = 25 '<----------------------------So cot DULIEU'

 

[Gió Đông]

Vietlotto tạo công việc với nhiều nỗ lực cho các thành viên GPE đây