NHỜ GIÚP ĐỠ LỌC RA CÁC ĐỊA CHỈ EMAIL TỪ LIST EMAIL SẴN CÓ (1 người xem)

nobita9112 · 5/8/19

Dear Các anh chị, e có 1 vấn đề nhờ các anh chị hỗ trợ giúp em.
e có 1 file đính kèm gồm 2 sheet :
* Sheet 1 là nơi cần lọc ra địa chỉ email và định danh của tên Công Ty cần tìm kiếm.
* Sheet 2 là data email có sẵn.
*** ****Yêu cầu là : khi e paste list tên Khách hàng vào cột A của sheet 1 => bấm nút lọc sẽ lọc ra định danh & địa chỉ email vào cột B và C của Công ty cần tìm kiếm.
*** Lưu ý 1 : là nếu có công ty nào có nhiều địa chỉ email thì cũng sẽ show ra hết các định danh và địa chỉ email của Cty đó.
*** Lưu ý 2 : nếu tên Cty cần tìm kiếm mà không có data trong sheet 2 thì sẽ warning & báo lại cho mình biết là ko có dữ liệu của Cty đó.
Do lượng dòng data email của em khá nhiều tầm hơn 800 KH và dòng dữ liệu cần lọc là hơn 150 KH nên nhờ các anh chị hỗ trợ em code cho vùng dữ liệu nhiều nhiều.
nhờ các anh chi giúp đỡ giúp em.
chân thành cám ơn các anh chi.

CHAOQUAY · 6/8/19

nobita9112 đã viết:
Dear Các anh chị, e có 1 vấn đề nhờ các anh chị hỗ trợ giúp em.
e có 1 file đính kèm gồm 2 sheet :
* Sheet 1 là nơi cần lọc ra địa chỉ email và định danh của tên Công Ty cần tìm kiếm.
* Sheet 2 là data email có sẵn.
*** ****Yêu cầu là : khi e paste list tên Khách hàng vào cột A của sheet 1 => bấm nút lọc sẽ lọc ra định danh & địa chỉ email vào cột B và C của Công ty cần tìm kiếm.
*** Lưu ý 1 : là nếu có công ty nào có nhiều địa chỉ email thì cũng sẽ show ra hết các định danh và địa chỉ email của Cty đó.
*** Lưu ý 2 : nếu tên Cty cần tìm kiếm mà không có data trong sheet 2 thì sẽ warning & báo lại cho mình biết là ko có dữ liệu của Cty đó.
Do lượng dòng data email của em khá nhiều tầm hơn 800 KH và dòng dữ liệu cần lọc là hơn 150 KH nên nhờ các anh chị hỗ trợ em code cho vùng dữ liệu nhiều nhiều.
nhờ các anh chi giúp đỡ giúp em.
chân thành cám ơn các anh chi.

Thử code dưới đây

Mã:

Sub DinhDanh_Email()
Dim Data As Variant
Dim Kq As Variant
Dim i, j, k
If Sheet1.Range("A2") = "" Then
    MsgBox "Khong co du lieu"
    Exit Sub
End If
Data = Sheet2.Range("A1").CurrentRegion
Kq = Sheet1.Range("A2", Sheet1.Range("A1000000").End(xlUp)).Resize(, 3)
With CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(Data)
        If .exists(Data(i, 1)) = False Then
            .Item(Data(i, 1)) = Array(Data(i, 2), Data(i, 3))
        Else
            j = .Item(Data(i, 1))
            j(0) = j(0) & ", " & Data(i, 2)
            j(1) = j(1) & ", " & Data(i, 3)
            .Item(Data(i, 1)) = j
        End If
    Next i
    For i = 1 To UBound(Kq)
        If .exists(Kq(i, 1)) Then
            Kq(i, 2) = .Item(Kq(i, 1))(0)
            Kq(i, 3) = .Item(Kq(i, 1))(1)
        Else
            Kq(i, 2) = "Khong co du lieu"
            Kq(i, 3) = "Khong co du lieu"
        End If
    Next i
End With
With Sheet1
    .Range("A2").Resize(UBound(Kq), UBound(Kq, 2)).ClearContents
    .Range("A2").Resize(UBound(Kq), UBound(Kq, 2)) = Kq
    .UsedRange.Columns.AutoFit
End With
End Sub

nobita9112 · 6/8/19

CHAOQUAY đã viết:

Thử code dưới đây

Mã:

Sub DinhDanh_Email()
Dim Data As Variant
Dim Kq As Variant
Dim i, j, k
If Sheet1.Range("A2") = "" Then
    MsgBox "Khong co du lieu"
    Exit Sub
End If
Data = Sheet2.Range("A1").CurrentRegion
Kq = Sheet1.Range("A2", Sheet1.Range("A1000000").End(xlUp)).Resize(, 3)
With CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(Data)
        If .exists(Data(i, 1)) = False Then
            .Item(Data(i, 1)) = Array(Data(i, 2), Data(i, 3))
        Else
            j = .Item(Data(i, 1))
            j(0) = j(0) & ", " & Data(i, 2)
            j(1) = j(1) & ", " & Data(i, 3)
            .Item(Data(i, 1)) = j
        End If
    Next i
    For i = 1 To UBound(Kq)
        If .exists(Kq(i, 1)) Then
            Kq(i, 2) = .Item(Kq(i, 1))(0)
            Kq(i, 3) = .Item(Kq(i, 1))(1)
        Else
            Kq(i, 2) = "Khong co du lieu"
            Kq(i, 3) = "Khong co du lieu"
        End If
    Next i
End With
With Sheet1
    .Range("A2").Resize(UBound(Kq), UBound(Kq, 2)).ClearContents
    .Range("A2").Resize(UBound(Kq), UBound(Kq, 2)) = Kq
    .UsedRange.Columns.AutoFit
End With
End Sub

good morning anh. đoạn code của anh em đang làm thử nhờ anh hỗ trợ giúp em 2 phần này giúp vì em gà code VBA nên xin anh hỗ trợ giúp em
e muốn thay đổi lại bố cục chút xiu theo file đính kèm mới , nhờ anh giúp đỡ code trực tiếp lên file đính kèm giúp em.
xin chân thành cám ơn anh.

CHAOQUAY · 6/8/19

nobita9112 đã viết:
good morning anh. đoạn code của anh em đang làm thử nhờ anh hỗ trợ giúp em 2 phần này giúp vì em gà code VBA nên xin anh hỗ trợ giúp em
e muốn thay đổi lại bố cục chút xiu theo file đính kèm mới , nhờ anh giúp đỡ code trực tiếp lên file đính kèm giúp em.
xin chân thành cám ơn anh.

Bạn xem file đính kèm

nobita9112 · 6/8/19

CHAOQUAY đã viết:
Bạn xem file đính kèm

Hi anh, e vừa test thử thì thấy 1 số lỗi chưa đúng như bên dưới, e xin a giúp em xem lại với ạ.:
1. em thử paste 1 tên cty vào rồi bấm LỌC thì sheet nó vẫn show không đúng tên cty đó, nó show 2 or 3 tên cty lận.
(vd như e cần tìm tên & paste tên Cty : HOANG ANH GIA LAI vào cột F của sheet 2 thì lọc nó ra đến 3 cty là : HOANG ANH GIA LAI, VIET NAM PROJECT và GATE WAY )
2. các cty có nhiều dòng địa chỉ email, cột địa chỉ anh có thể code giúp em sao mà nó có thể show theo hàng dọc thay vì hàng ngang ko.
3. cột F của sheet 2 thường e cần tìm trung bình từ 80-110 KH lận nên nhờ anh code lai cho vùng dữ liệu tầm 150 dòng giúp em với a.
kể cả vùng em tô màu ak, là vùng e cần nhập data nhiều nên a code vùng dữ liệu của sheet 1 cột A,B,C và sheet 2 cột A,B,C nhiều nhiều giúp em với a.
phiền anh quá nhưng thật sự e đang bí quá

CHAOQUAY · 6/8/19

nobita9112 đã viết:
Hi anh, e vừa test thử thì thấy 1 số lỗi chưa đúng như bên dưới, e xin a giúp em xem lại với ạ.:
1. em thử paste 1 tên cty vào rồi bấm LỌC thì sheet nó vẫn show không đúng tên cty đó, nó show 2 or 3 tên cty lận.
(vd như e cần tìm tên & paste tên Cty : HOANG ANH GIA LAI vào cột F của sheet 2 thì lọc nó ra đến 3 cty là : HOANG ANH GIA LAI, VIET NAM PROJECT và GATE WAY )
2. các cty có nhiều dòng địa chỉ email, cột địa chỉ anh có thể code giúp em sao mà nó có thể show theo hàng dọc thay vì hàng ngang ko.
3. cột F của sheet 2 thường e cần tìm trung bình từ 80-110 KH lận nên nhờ anh code lai cho vùng dữ liệu tầm 150 dòng giúp em với a.
phiền anh quá nhưng thật sự e đang bí quá

Bạn gửi file lỗi lên cho dễ xử lý
Mẫu kết quả mong muốn thế nào đưa lên luôn

nobita9112 · 6/8/19

CHAOQUAY đã viết:
Bạn gửi file lỗi lên cho dễ xử lý
Mẫu kết quả mong muốn thế nào đưa lên luôn

e gởi anh file ạ, a có thể cho e contact để e call cho anh dể hiểu dc ko ạ ?

CHAOQUAY · 7/8/19

@nobita9112
"file của anh code e tìm thử thì ko ra được như vậy . e lọc 6cty mà ra 11 cty lận."
Đây chỉ là lỗi khi điền kết quả xuống sheet. Phần tính toán không sai.
Bạn tìm đọan cuối này trong code

Mã:

With Sheet1
    .Range("A2").Resize(5000, UBound(Kq, 2)).ClearContents
    .Range("A2").Resize(UBound(Kq), UBound(Kq, 2)) = Kq
    .UsedRange.Columns.AutoFit
    .Activate
End With

Thay dưới đây vào

Mã:

With Sheet1
    '.Range("A2").Resize(UBound(Kq), UBound(Kq, 2)).ClearContents
    .Range("A2").Resize(5000, UBound(Kq, 2)).ClearContents
    .Range("A2").Resize(UBound(Kq), UBound(Kq, 2)) = Kq
    .UsedRange.Columns.AutoFit
    .Activate
End With

CHAOQUAY · 7/8/19

nobita9112 đã viết:
e gởi anh file ạ, a có thể cho e contact để e call cho anh dể hiểu dc ko ạ ?

Không phức tạp quá đâu bạn.
Bạn xem code & file đính kèm.

Mã:

Sub DinhDanh_Email_1()
Dim Data As Variant
Dim Dk As Variant
Dim Kq As Variant
Dim i, j, k, x, z, t
With Sheet2
    If .Range("F2") = "" Then
        MsgBox "Khong co du lieu"
        Exit Sub
    End If
    Data = .Range("A1").CurrentRegion
    Dk = .Range("F2", .Range("F1000000").End(xlUp))
End With
ReDim Kq(1 To UBound(Data), 1 To UBound(Data, 2))
With CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(Data)
        If .exists(Data(i, 1)) = False Then
            .Item(Data(i, 1)) = Array(Array(Data(i, 2)), Array(Data(i, 3)))
        Else
            x = .Item(Data(i, 1))(0)
            z = .Item(Data(i, 1))(1)
            t = UBound(.Item(Data(i, 1))(0))
            ReDim Preserve x(t + 1), z(t + 1)
            x(t + 1) = Data(i, 2)
            z(t + 1) = Data(i, 3)
            .Item(Data(i, 1)) = Array(x, z)
        End If
    Next i
    k = 0
    For i = 1 To UBound(Dk)
        If .exists(Dk(i, 1)) Then
            Kq(k + 1, 1) = Dk(i, 1)
            x = .Item(Dk(i, 1))(0)
            z = .Item(Dk(i, 1))(1)
            t = UBound(.Item(Dk(i, 1))(0))
            For j = 0 To t
                k = k + 1
                Kq(k, 2) = x(j)
                Kq(k, 3) = z(j)
            Next j
        Else
            k = k + 1
            Kq(k, 1) = Dk(i, 1)
            Kq(k, 2) = "Khong co du lieu"
            Kq(k, 3) = "Khong co du lieu"
        End If
    Next i
End With
With Sheet1
    .Range("A2").Resize(10000, UBound(Kq, 2)).ClearContents 'thay doi 10000 neu can
    .Range("A2").Resize(k, UBound(Kq, 2)) = Kq
    .UsedRange.Columns.AutoFit
    .Activate 'bo lenh nay neu can
End With
End Sub

nobita9112 · 7/8/19

CHAOQUAY đã viết:

Không phức tạp quá đâu bạn.
Bạn xem code & file đính kèm.

Mã:

Sub DinhDanh_Email_1()
Dim Data As Variant
Dim Dk As Variant
Dim Kq As Variant
Dim i, j, k, x, z, t
With Sheet2
    If .Range("F2") = "" Then
        MsgBox "Khong co du lieu"
        Exit Sub
    End If
    Data = .Range("A1").CurrentRegion
    Dk = .Range("F2", .Range("F1000000").End(xlUp))
End With
ReDim Kq(1 To UBound(Data), 1 To UBound(Data, 2))
With CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(Data)
        If .exists(Data(i, 1)) = False Then
            .Item(Data(i, 1)) = Array(Array(Data(i, 2)), Array(Data(i, 3)))
        Else
            x = .Item(Data(i, 1))(0)
            z = .Item(Data(i, 1))(1)
            t = UBound(.Item(Data(i, 1))(0))
            ReDim Preserve x(t + 1), z(t + 1)
            x(t + 1) = Data(i, 2)
            z(t + 1) = Data(i, 3)
            .Item(Data(i, 1)) = Array(x, z)
        End If
    Next i
    k = 0
    For i = 1 To UBound(Dk)
        If .exists(Dk(i, 1)) Then
            Kq(k + 1, 1) = Dk(i, 1)
            x = .Item(Dk(i, 1))(0)
            z = .Item(Dk(i, 1))(1)
            t = UBound(.Item(Dk(i, 1))(0))
            For j = 0 To t
                k = k + 1
                Kq(k, 2) = x(j)
                Kq(k, 3) = z(j)
            Next j
        Else
            k = k + 1
            Kq(k, 1) = Dk(i, 1)
            Kq(k, 2) = "Khong co du lieu"
            Kq(k, 3) = "Khong co du lieu"
        End If
    Next i
End With
With Sheet1
    .Range("A2").Resize(10000, UBound(Kq, 2)).ClearContents 'thay doi 10000 neu can
    .Range("A2").Resize(k, UBound(Kq, 2)) = Kq
    .UsedRange.Columns.AutoFit
    .Activate 'bo lenh nay neu can
End With
End Sub

Hi anh, file bị lỗi ko chạy macro được anh ơi, dù em đã nhấn vào biểu tượng tròn bên góc trái của Excel ->Chọn Excel Option -> chọn Trust center -> chọn Trust center settings ->Chọn Macro settings ->Chọn Enable all Macros nhấn ok rồi.... hic gic

ExcelQN · 7/8/19

nobita9112 đã viết:
Hi anh, file bị lỗi ko chạy macro được anh ơi, dù em đã nhấn vào biểu tượng tròn bên góc trái của Excel ->Chọn Excel Option -> chọn Trust center -> chọn Trust center settings ->Chọn Macro settings ->Chọn Enable all Macros nhấn ok rồi.... hic gic

Chạy rồi (vì gán sai tên macro thôi)

nobita9112 · 7/8/19

ExcelQN đã viết:
Chạy rồi (vì gán sai tên macro thôi)

e xin đa tạ anh nhiều, file chạy ổn rồi anh, e cám ơn nhiều.

NHỜ GIÚP ĐỠ LỌC RA CÁC ĐỊA CHỈ EMAIL TỪ LIST EMAIL SẴN CÓ (1 người xem)

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

nobita9112

Thành viên mới

File đính kèm

CHAOQUAY

Thành viên gắn bó

nobita9112

Thành viên mới

File đính kèm

CHAOQUAY

Thành viên gắn bó

File đính kèm

nobita9112

Thành viên mới

CHAOQUAY

Thành viên gắn bó

nobita9112

Thành viên mới

File đính kèm

CHAOQUAY

Thành viên gắn bó

CHAOQUAY

Thành viên gắn bó

File đính kèm

nobita9112

Thành viên mới

ExcelQN

Thành viên hoạt động

File đính kèm

nobita9112

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