VBA copy sheet qua sheet co dieu kien (1 người xem)

[MeThuongNho]

Dear Anh /Chị,
Em cần copy giá trị từ sheet THDH qua sheet TONGHOP có điều kiện theo file và hình đính kèm.
Mong mọi người giúp đỡ.
Cám ơn Anh/ Chị nhiều!

 

[PacificPR]

Dear Anh /Chị,
Em cần copy giá trị từ sheet THDH qua sheet TONGHOP có điều kiện theo file và hình đính kèm.
Mong mọi người giúp đỡ.
Cám ơn Anh/ Chị nhiều!

Bạn dùng thử cái này

Sub CopyData()
    Dim sArr(), dArr(), I As Long, J As Long, K As Long
With Sheets("THDH")
    sArr = .Range("A2", .Range("A65535").End(3)).Resize(,11).Value
    ReDim dArr(1 To UBound(sArr), 1 To UBound(sArr, 2))
    For I = 1 To UBound(sArr)
        If sArr(I, 4) <> Empty Then
            K = K + 1
            For J = 1 To UBound(sArr, 2)
                dArr(K, J) = sArr(I, J)
            Next J
        End If
    Next I
End With
With Sheets("TONGHOP")
    .Range("A2:K" & .Range("A65535").End(3).Row + 1).ClearContents
    .Range("A2").Resize(K, UBound(sArr, 2)) = dArr
End With
End Sub

 

[giaiphap]

Bạn dùng thử code này xem sao.

Sub GPE()
Dim Arr(), dArr(), i As Long, j As Long, k As Long
Arr = Sheet1.Range("A2:K" & Sheet1.Range("A65000").End(xlUp).Row).Value
ReDim dArr(1 To UBound(Arr), 1 To 11)
For i = 1 To UBound(Arr)
    If Arr(i, 4) <> Empty Then
        k = k + 1: dArr(k, 1) = k
        For j = 2 To 11
            dArr(k, j) = Arr(i, j)
        Next j
    End If
Next i
If k <> 0 Then
    Sheet2.Range("A65000").End(xlUp).Offset(1).Resize(k, 11) = dArr
End If
End Sub

 

[MeThuongNho]

Thanks Pacific PR:
Pacific PR xem lại giúp với nha, Code chỉ lấy được mỗi cột A.
Thân!

 

[MeThuongNho]

Cám ơn giaiphap,
Code anh rất hay, nhưng lại bị lặp lại khi chạy lại lần nữa, mình muốn chạy lại với điều kiện không trùng số SX thì sửa sao ạ.
( THÊM: Với nếu mình muốn tăng vùng dữ liệu thì sửa code chỗ nào, vì code Dim i, j k mình k rành nên chỉ giúp mình với)
(ĐK vùng mới : từ A6: Y3200, số SX vẫn là cột D.)
Giúp mình với nha, đang gấp lắm.
Cám ơn nhiều!

 

[giaiphap]

Cám ơn giaiphap,
Code anh rất hay, nhưng lại bị lặp lại khi chạy lại lần nữa, mình muốn chạy lại với điều kiện không trùng số SX thì sửa sao ạ.
( THÊM: Với nếu mình muốn tăng vùng dữ liệu thì sửa code chỗ nào, vì code Dim i, j k mình k rành nên chỉ giúp mình với)
(ĐK vùng mới : từ A6: Y3200, số SX vẫn là cột D.)
Giúp mình với nha, đang gấp lắm.
Cám ơn nhiều!

Muốn gì thì đưa file thật lên đây, nêu yêu cầu cụ thể. Bạn muốn kiểm tra không trùng là sao? tức là cái nào có rồi thì không ghi vào sheet TONGHOP đúng không? Hay là khi ghi lại dữ liệu sang sheet TONGHOP thì xóa dữ liệu cũ trước khi ghi hay như thế nào nửa?

 

[MeThuongNho]

Dear giaiphap,
Do file lớn nên em tách ra 2 sheet này cho anh làm giúp em nha.
Cám ơn Anh,
Yêu cầu anh nói đúng rồi ak: Tức là cái nào copy rồi thì không ghi vào sheet TONGHOP nữa.
VÀ yêu cầu 2 ( cho file khác em cũng đang cần) là ghi vào lần nữa thì sheet TONGHOP xoá đi dữ liệu trước đo
Cái yêu cầu 1 em đang gấp hơn, mong anh chỉ giúp.
Cám ơn Anh nhiều!

 

[MeThuongNho]

Dear giaiphap,
Do file lớn nên em tách ra 2 sheet này cho anh làm giúp em nha.
Cám ơn Anh,
Yêu cầu anh nói đúng rồi ak: Tức là cái nào copy rồi thì không ghi vào sheet TONGHOP nữa.
VÀ yêu cầu 2 ( cho file khác em cũng đang cần) là ghi vào lần nữa thì sheet TONGHOP xoá đi dữ liệu trước đó.
Cái yêu cầu 1 em đang gấp hơn, mong anh chỉ giúp.
(Nếu được a cho em xin riêng 1 Code: bỏ 3 cột L,M,N: em không cần copy 3 cột này, nhưng sợ nhiều khi cần phải copy)
Cám ơn Anh nhiều lắm!

 

[giaiphap]

Bạn sử dụng đoạn code này thử cho yêu cầu 1, nhớ bỏ 3 cột L, M, N bên sheet TONGHOP.

Sub GPE()
Dim Arr(), dArr(), sArr(), i As Long, j As Long, k As Long
Dim Dic As Object, Tmp As String
Arr = Sheet1.Range("A3:Y" & Sheet1.Range("B65000").End(xlUp).Row).Value
k = Sheet2.Range("D65000").End(xlUp).Row
Set Dic = CreateObject("Scripting.Dictionary")
ReDim dArr(1 To UBound(Arr), 1 To 25)
With Dic
If k > 1 Then
    sArr = Sheet2.Range("D2:V" & k).Value
    k = 0
    For i = 1 To UBound(sArr)
        Tmp = Arr(i, 4)
        If Not .Exists(Tmp) Then
             k = k + 1: dArr(k, 1) = k
            .Add Tmp, k
            For j = 2 To 22
                dArr(k, j) = Arr(i, j)
            Next j
        End If
    Next i
Else
    k = 0
End If
For i = 1 To UBound(Arr)
    If Arr(i, 4) <> Empty Then
        Tmp = Arr(i, 4)
        If Not .Exists(Tmp) Then
            k = k + 1: dArr(k, 1) = k
            .Add Tmp, k
            For j = 2 To 11
                dArr(k, j) = Arr(i, j)
            Next j
            For j = 15 To 25
                dArr(k, j - 3) = Arr(i, j)
            Next j
        End If
    End If
Next i
End With
If k <> 0 Then
    i = Sheet2.Range("A65000").End(xlUp).Row
    If i > 1 Then Sheet2.Range("A2:V" & i).ClearContents
    Sheet2.Range("A65000").End(xlUp).Offset(1).Resize(k, 22) = dArr
End If
End Sub

 

[MeThuongNho]

Cám ơn Anh giaiphap nhiều,
Vì gấp nên nhận được trợ giúp của anh em làm liền nek.
Code chạy trên file OK.
Nhưng file em giờ sheet TONGHOP là có mấy cái ISO biểu mẫu cần chèn trên cùng. Nên khi em insert, nó vẫn cứ copy từ dòng 2 trở đi.
Em muốn data nằm từ dòng 6 thì code sửa chỗ nào Anh?
Và sheet THDH data cũng từ dòng 6 thì sửa chỗ này phải k anh: Arr = Sheet1.Range("A6:Y" & Sheet1.Range("B3500").End(xlUp).Row).Value
Anh xem lại giúp em nha,
Thanks!

 

[MeThuongNho]

Dear giaiphap,
Anh ơi, giúp em vấn đề trên với nha.

Với lai: Code không ổn rồi anh ơi:
Nhấp chạy lần 1 OK.
Lần 2 trở đi: dữ liệu bị dời sang 3 cột từ cột Ghi chú.
Anh xem giúp em, cám ơn Anh!