Cần giúp VBA : Đưa dữ liệu ở 2 cột thành 1 cột (1 người xem)

nguyenvankhang · 16/11/17

Chào các anh .
Mong các anh giúp đỡ code 1 đoạn VBA giúp đữa dữ liệu ở cột A và cột B vào cột C như hình bên dưới

Mong các anh giúp em . cảm ơn ! ( Có 1 bài bị sai tiêu đề mong admin xóa bài kia giúp em nhé . )

vanthinh3101 · 16/11/17

nguyenvankhang đã viết:
Chào các anh .
Mong các anh giúp đỡ code 1 đoạn VBA giúp đữa dữ liệu ở cột A và cột B vào cột C như hình bên dưới

Mong các anh giúp em . cảm ơn ! ( Có 1 bài bị sai tiêu đề mong admin xóa bài kia giúp em nhé . )

Code cho bạn

Mã:

Sub GPE()
    Dim sArr(), dArr()
    Dim I As Long, J As Long, K As Long, lR1 As Long, lR2 As Long
    
    lR1 = Range("A" & Rows.Count).End(xlUp).Row
    lR2 = Range("B" & Rows.Count).End(xlUp).Row
    If lR1 > lR2 Then
        sArr() = Range("A1:A" & lR1).Resize(, 2).Value
    Else
        sArr() = Range("A1:A" & lR2).Resize(, 2).Value
    End If
    ReDim dArr(1 To (lR1 + lR2), 1 To 1)
    For J = 1 To UBound(sArr, 2)
        For I = 1 To UBound(sArr, 1)
            If Len(Trim(sArr(I, J))) Then
                K = K + 1
                dArr(K, 1) = sArr(I, J)
            End If
        Next I
    Next J
    Range("C1").Resize(K) = dArr
End Sub

PacificPR · 16/11/17

Em góp vui với con "Ma Cà Rồng" này nha

PHP:

Sub Macro1()
    Dim sRng As Range, J As Long, Ec As Long, Ep As Long
Application.ScreenUpdating = False
With Sheet1
    For J = 2 To 3
        Ec = .Cells(Rows.Count, J).End(3).Row + 1
        Set sRng = .Range(.Cells(1, J), .Cells(Ec, J).End(3)) _
                .SpecialCells(xlCellTypeConstants, 23)
        Ep = .Cells(Rows.Count, 4).End(3).Row
        If Ep > 1 Then Ep = Ep + 1
        sRng.Copy .Cells(Ep, 4)
    Next J
End With
Application.ScreenUpdating = True
End Sub

nguyenvankhang · 17/11/17

Em cảm ơn

PacificPR đã viết:

Em góp vui với con "Ma Cà Rồng" này nha

PHP:

Sub Macro1()
    Dim sRng As Range, J As Long, Ec As Long, Ep As Long
Application.ScreenUpdating = False
With Sheet1
    For J = 2 To 3
        Ec = .Cells(Rows.Count, J).End(3).Row + 1
        Set sRng = .Range(.Cells(1, J), .Cells(Ec, J).End(3)) _
                .SpecialCells(xlCellTypeConstants, 23)
        Ep = .Cells(Rows.Count, 4).End(3).Row
        If Ep > 1 Then Ep = Ep + 1
        sRng.Copy .Cells(Ep, 4)
    Next J
End With
Application.ScreenUpdating = True
End Sub

Em cảm ơn 2 bác đã giúp em . em quân mất 1 vấn đề này nữa ạ.
- VBA tự động chạy khi nhập dữ liệu vào cột A và B
- Trường hợp dữ liệu đã có trong cột C thì sẽ không copy từ cột A,B sang nữa . Ví dụ Nguyễn Văn A trong cột C đã có rồi thì không Copy Nguyễn Văn A từ cột A,B sang cột C nữa .

thanks

PacificPR · 17/11/17

nguyenvankhang đã viết:
Em cảm ơn

Em cảm ơn 2 bác đã giúp em . em quân mất 1 vấn đề này nữa ạ.
- VBA tự động chạy khi nhập dữ liệu vào cột A và B
- Trường hợp dữ liệu đã có trong cột C thì sẽ không copy từ cột A,B sang nữa . Ví dụ Nguyễn Văn A trong cột C đã có rồi thì không Copy Nguyễn Văn A từ cột A,B sang cột C nữa .

thanks

Bạn thử cái này xem sao:
1.Kiểm tra sự tồn tại của chuỗi trong vùng

PHP:

Function Kiemtra(Str As String, Rng As Range) As Boolean
    Dim Dk As Boolean
Dk = False
For Each Cll In Rng
    If Cll = Str Then
        Dk = True
        Exit For
    End If
Next
Kiemtra = Dk
End Function

2. Code trong Sheet

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
    Dim Er As Long
Er = Range("D" & Rows.Count).End(3).Row + 1
With Target
    If .Column = 2 Or .Column = 3 Then
        If Kiemtra(Target.Value, Range("D1", _
                Range("D" & Rows.Count).End(3))) = False _
                Then Range("D" & Er) = Target.Value
    End If
End With
End Sub

ndu96081631 · 17/11/17

PacificPR đã viết:

Bạn thử cái này xem sao:
1.Kiểm tra sự tồn tại của chuỗi trong vùng

PHP:

Function Kiemtra(Str As String, Rng As Range) As Boolean
    Dim Dk As Boolean
Dk = False
For Each Cll In Rng
    If Cll = Str Then
        Dk = True
        Exit For
    End If
Next
Kiemtra = Dk
End Function

2. Code trong Sheet

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
    Dim Er As Long
Er = Range("D" & Rows.Count).End(3).Row + 1
With Target
    If .Column = 2 Or .Column = 3 Then
        If Kiemtra(Target.Value, Range("D1", _
                Range("D" & Rows.Count).End(3))) = False _
                Then Range("D" & Er) = Target.Value
    End If
End With
End Sub

Đoạn If Cll = Str Then là hơi chủ quan. Sao biết chắc rằng người ta có phân biệt HOA thường? Như code ấy thì Nguyễn Anh Tuấn sẽ <> NGUYỄN AN H TUẤN đó nha!
Ngoài ra: code này nếu xét về mặt thuật toán thì nó không hay tí nào cả. Cứ mỗi lần có thay đổi trên sheet thì phải kiểm tra toàn bộ, cả những dữ liệu đã kiểm tra trước đó ---> Quá mất thời gian!
Theo tôi thì quy trình phải thế này:
- Đầu tiên khi khởi động file, dùng sự kiện Workbook_Open (hoặc Sub AutOpen) để ghép 2 cột vào làm 1, đồng thời loại bỏ dữ liệu trùng luôn
- Tiếp theo, sau khi lấy được kết quả, gán xuống sheet và đồng thời "bắn" kết quả ấy vào 1 biến dictionary toàn cục
- Từ giờ, mỗi khi có thay đổi trên sheet, chỉ cần dùng Dic.Exists để kiểm tra
Vậy điều cần làm là:
- Tạo 1 hàm nối mảng 2 chiều có tùy chọn loại bỏ trùng hoặc không.
- Tạo code lấy dữ liệu khi file vừa khởi động và đưa dữ liệu vào biến toàn cục
- Tạo sự kiện Worksheet_Change
-------------------------------------
Nói chung: vấn đề khá phức tạp, chỉ một vài dòng code thì chẳng làm được gì cả

PacificPR · 17/11/17

ndu96081631 đã viết:
Đoạn If Cll = Str Then là hơi chủ quan. Sao biết chắc rằng người ta có phân biệt HOA thường? Như code ấy thì Nguyễn Anh Tuấn sẽ <> NGUYỄN AN H TUẤN đó nha!
Ngoài ra: code này nếu xét về mặt thuật toán thì nó không hay tí nào cả. Cứ mỗi lần có thay đổi trên sheet thì phải kiểm tra toàn bộ, cả những dữ liệu đã kiểm tra trước đó ---> Quá mất thời gian!
Theo tôi thì quy trình phải thế này:
- Đầu tiên khi khởi động file, dùng sự kiện Workbook_Open (hoặc Sub AutOpen) để ghép 2 cột vào làm 1, đồng thời loại bỏ dữ liệu trùng luôn
- Tiếp theo, sau khi lấy được kết quả, gán xuống sheet và đồng thời "bắn" kết quả ấy vào 1 biến dictionary toàn cục
- Từ giờ, mỗi khi có thay đổi trên sheet, chỉ cần dùng Dic.Exists để kiểm tra
Vậy điều cần làm là:
- Tạo 1 hàm nối mảng 2 chiều có tùy chọn loại bỏ trùng hoặc không.
- Tạo code lấy dữ liệu khi file vừa khởi động và đưa dữ liệu vào biến toàn cục
- Tạo sự kiện Worksheet_Change
-------------------------------------
Nói chung: vấn đề khá phức tạp, chỉ một vài dòng code thì chẳng làm được gì cả

Em sửa lại như thế này đơn giản hơn 1 chút Thầy ạ

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
    Dim Er As Long, Rng As Range
With Target
    If .Column = 2 Or .Column = 3 Then
        Set Rng = Range("D1", Range("D" & Rows.Count).End(3))
        If Application.WorksheetFunction.CountIf(Rng, Target.Value) < 1 Then
            Er = Range("D" & Rows.Count).End(3).Row + 1
            If Range("D1") = Empty Then Er = 1
            Range("D" & Er) = Target.Value
        End If
    End If
End With
End Sub

ndu96081631 · 17/11/17

PacificPR đã viết:

Em sửa lại như thế này đơn giản hơn 1 chút Thầy ạ

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
    Dim Er As Long, Rng As Range
With Target
    If .Column = 2 Or .Column = 3 Then
        Set Rng = Range("D1", Range("D" & Rows.Count).End(3))
        If Application.WorksheetFunction.CountIf(Rng, Target.Value) < 1 Then
            Er = Range("D" & Rows.Count).End(3).Row + 1
            If Range("D1") = Empty Then Er = 1
            Range("D" & Er) = Target.Value
        End If
    End If
End With
End Sub

Worksheet_Change không chỉ làm việc với 1 cell. Trong trường hợp người ta copy và paste vào cột B hoặc C hoặc cả 2 cột thì... sao?
Ăn chắc code sẽ lập tức báo lỗi tại đoạn Target.Value. Do bạn có "On Error Resume Next" nên sẽ vượt qua lỗi nhưng lại nhận một kết quả.. trật lất

PacificPR · 17/11/17

ndu96081631 đã viết:
Worksheet_Change không chỉ làm việc với 1 cell. Trong trường hợp người ta copy và paste vào cột B hoặc C hoặc cả 2 cột thì... sao?
Ăn chắc code sẽ lập tức báo lỗi tại đoạn Target.Value. Do bạn có "On Error Resume Next" nên sẽ vượt qua lỗi nhưng lại nhận một kết quả.. trật lất

Dạ. Đúng rồi Thầy ạ. Cám ơn Thầy nhiều
Em cố đu đeo một lần này nữa thôi ạ. Em sửa lại thành như thế này thì hết lỗi rồi

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Er As Long, Rng As Range, eRng As Range
Application.ScreenUpdating = False
With Target
    If .Column = 2 Or .Column = 3 Then
        Set eRng = Target
        For Each Cll In eRng
            Set Rng = Range("D1", Range("D" & Rows.Count).End(3))
            If Cll <> Empty Then
                If Application.WorksheetFunction.CountIf(Rng, Cll) < 1 Then
                    Er = Range("D" & Rows.Count).End(3).Row + 1
                    If Range("D1") = Empty Then Er = 1
                    Range("D" & Er) = Cll.Value
                End If
            End If
        Next
    End If
End With
Application.ScreenUpdating = True
End Sub

VetMini · 17/11/17

Mình cứ nghĩ bài nay chỉ cần copy sang cột mới, filter, rồi remove duplicate. Cốt kiếc làm chi vậy?

phulien1902 · 17/11/17

PacificPR đã viết:

Dạ. Đúng rồi Thầy ạ. Cám ơn Thầy nhiều
Em cố đu đeo một lần này nữa thôi ạ. Em sửa lại thành như thế này thì hết lỗi rồi

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Er As Long, Rng As Range, eRng As Range
Application.ScreenUpdating = False
With Target
    If .Column = 2 Or .Column = 3 Then
        Set eRng = Target
        For Each Cll In eRng
            Set Rng = Range("D1", Range("D" & Rows.Count).End(3))
            If Cll <> Empty Then
                If Application.WorksheetFunction.CountIf(Rng, Cll) < 1 Then
                    Er = Range("D" & Rows.Count).End(3).Row + 1
                    If Range("D1") = Empty Then Er = 1
                    Range("D" & Er) = Cll.Value
                End If
            End If
        Next
    End If
End With
Application.ScreenUpdating = True
End Sub

Ổn roài...

ndu96081631 · 17/11/17

VetMini đã viết:
Mình cứ nghĩ bài nay chỉ cần copy sang cột mới, filter, rồi remove duplicate. Cốt kiếc làm chi vậy?

Chính xác là nên làm cách này cho bài này. Con viết code là dành cho những trường hợp tổng quát, dùng được cho array hoặc range.
Điều đó có nghĩa là:
- Nếu muốn code tổng quát thì nên viết trên array
- Nếu đã For each cel in range.. gì gì đó thì thôi cứ dùng các công cụ có sẵn cho gọn

nguyenvankhang · 18/11/17

ndu96081631 đã viết:
Chính xác là nên làm cách này cho bài này. Con viết code là dành cho những trường hợp tổng quát, dùng được cho array hoặc range.
Điều đó có nghĩa là:
- Nếu muốn code tổng quát thì nên viết trên array
- Nếu đã For each cel in range.. gì gì đó thì thôi cứ dùng các công cụ có sẵn cho gọn

cái hình ảnh trên chỉ là em làm tượng trung thôi bác à . File em đang làm : Công ty có 5 xưởng, trong mỗi sưởng có 10 tổ
Giải pháp em làm và sau khi được các bác chỉ dẫn em đã làm thành công - Em làm 1 Sheet cài đặt -> trình bày các xưởng và tổ trong xưởng => khi thay đổi nội dung các tổ trong xưởng(VD: thực hiện thao tác đổi tổ 15 từ xưởng 3 sang xưởng 5) thì sẽ tự động chạy cái em nhờ các bác ở trên đấy .
= vậy theo các bác làm tay hơn hay những cái các bác giúp em tốt hơn

Cuối cùng cũng cảm ơn các bác nhiều!

VetMini · 18/11/17

nguyenvankhang đã viết:
cái hình ảnh trên chỉ là em làm tượng trung thôi bác à . File em đang làm : Công ty có 5 xưởng, trong mỗi sưởng có 10 tổ
Giải pháp em làm và sau khi được các bác chỉ dẫn em đã làm thành công - Em làm 1 Sheet cài đặt -> trình bày các xưởng và tổ trong xưởng => khi thay đổi nội dung các tổ trong xưởng(VD: thực hiện thao tác đổi tổ 15 từ xưởng 3 sang xưởng 5) thì sẽ tự động chạy cái em nhờ các bác ở trên đấy .
= vậy theo các bác làm tay hơn hay những cái các bác giúp em tốt hơn

Cuối cùng cũng cảm ơn các bác nhiều!

Cái tôi chỉ cho là phương pháp làm chủ tình hình.
Chứ đem lên đây nhờ viết code chạy tự động, sai sót gì thì "có vấn đề phát sinh, phiền bạn thêm chút nữa nhé" dĩ nhiên là phương pháp nhàn hạ nhất rồi.

lq177 · 18/11/17

PacificPR đã viết:

Dạ. Đúng rồi Thầy ạ. Cám ơn Thầy nhiều
Em cố đu đeo một lần này nữa thôi ạ. Em sửa lại thành như thế này thì hết lỗi rồi

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Er As Long, Rng As Range, eRng As Range
Application.ScreenUpdating = False
With Target
    If .Column = 2 Or .Column = 3 Then
        Set eRng = Target
        For Each Cll In eRng
            Set Rng = Range("D1", Range("D" & Rows.Count).End(3))
            If Cll <> Empty Then
                If Application.WorksheetFunction.CountIf(Rng, Cll) < 1 Then
                    Er = Range("D" & Rows.Count).End(3).Row + 1
                    If Range("D1") = Empty Then Er = 1
                    Range("D" & Er) = Cll.Value
                End If
            End If
        Next
    End If
End With
Application.ScreenUpdating = True
End Sub

Xin lỗi chủ topic cho em ké tý, xin các bác sửa giúp em code để em dùng copy từ các sheet khác nhau
VD chủ topic là 2 cột 1 và 2 ở cùng 1 sheet còn em cần là cột 1 và 2 ở 2 sheet khác nhau
Mong bác giúp cho

nguyenvankhang · 18/11/17

VetMini đã viết:
Cái tôi chỉ cho là phương pháp làm chủ tình hình.
Chứ đem lên đây nhờ viết code chạy tự động, sai sót gì thì "có vấn đề phát sinh, phiền bạn thêm chút nữa nhé" dĩ nhiên là phương pháp nhàn hạ nhất rồi.

cảm ơn anh đã góp ý .

Cần giúp VBA : Đưa dữ liệu ở 2 cột thành 1 cột (1 người xem)

Người dùng đang xem chủ đề này

nguyenvankhang

Thành viên mới

vanthinh3101

Thành viên tích cực

PacificPR

Thành viên mới

nguyenvankhang

Thành viên mới

PacificPR

Thành viên mới

ndu96081631

Huyền thoại GPE

PacificPR

Thành viên mới

ndu96081631

Huyền thoại GPE

PacificPR

Thành viên mới

VetMini

Ăn cùng góc phố

phulien1902

GPE - My love

ndu96081631

Huyền thoại GPE

nguyenvankhang

Thành viên mới

VetMini

Ăn cùng góc phố

lq177

Thành viên thường trực

nguyenvankhang

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

Đếm ngược thời gian