How to find Data if the Same Only and Value To other sheet. VBA Help

P

punnipah

Board Regular
Joined
Nov 3, 2021
Messages
134
Office Version
  1. 2019
Platform
  1. Windows
Hi, All

i would like to Type VBA
1. How to find Data in Sheet1
2.Then Vlook up to find the same values in Sheet 2
3.Enter the obtained results into the Sheet output.



Please help me.
Thank you Very Much



Sheet1
Datatest.xlsx
ABCD
1Merchant IDDevice ID
2230330611
3230330611
4230330275
5230330568
6230330560
7230330832
8230330832
9
10
11
12
13
Sheet1





Sheet 2
Datatest.xlsx
ABCDE
1NoBank LocMobile NoUserID
2186140611AKC
3286140610AKC
4386140590AKC
5486131923AKC
6586131832AKC
7686131832AKC
8
9
10
11
12
13
14
15End of Report
Sheet2





output Sheet

Datatest.xlsx
ABCDEF
1No.1Merchant IDDevice ID
2230330611
3230330611
4
5NoBank LocMobile NoUserID
6186140611AKC
7
8
9No.2Merchant IDDevice ID
10230330832
11230330832
12
13NoBank LocMobile NoUserID
14586131832AKC
15686131832AKC
16
17
18
19
output
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
Sort by date Sort by votes
Hello @punnipah .
Thanks for posting on MrExcel board.​

The following macro has reduced code. But maybe it's slow if you have thousands of records in your sheets.
VBA Code: 
Sub FindDataToOutput_v0()
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
  Dim dic As Object, ky As Variant
  Dim c As Range, f As Range
  Dim lr1 As Long, lr2 As Long, lr3 As Long, n As Long
  
  Application.ScreenUpdating = False
  
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  Set sh3 = Sheets("Output")
  Set dic = CreateObject("Scripting.Dictionary")
  lr1 = sh1.Range("B" & Rows.Count).End(3).Row
  lr2 = sh2.Range("C" & Rows.Count).End(3).Row
  sh3.Cells.ClearContents
  
  For Each c In sh1.Range("B2:B" & lr1)
    dic(c.Value) = Empty
  Next
  
  lr3 = 1
  For Each ky In dic.keys
    Set f = sh2.Range("C:C").Find(ky, , xlValues, xlWhole, , , False)
    If Not f Is Nothing Then
      n = n + 1
      sh1.Range("A1:B" & lr1).AutoFilter 2, ky
      sh3.Range("A" & lr3).Value = "No." & n
      sh1.AutoFilter.Range.Copy
      sh3.Range("B" & lr3).PasteSpecial xlPasteValues
      sh2.Range("A1:D" & lr2).AutoFilter 3, ky
      lr3 = sh3.Range("C" & Rows.Count).End(3).Row + 2
      sh2.AutoFilter.Range.Copy
      sh3.Range("B" & lr3).PasteSpecial xlPasteValues
      lr3 = sh3.Range("C" & Rows.Count).End(3).Row + 3
      sh2.Range("A1").AutoFilter
    End If
  Next
  sh1.Range("A1").AutoFilter
  Application.ScreenUpdating = True
End Sub

--------------------------------------​
The following macro is larger, but certainly faster than the previous one, if you have thousands of records.
VBA Code: 
Sub FindDataToOutput_v1()
  Dim dic As Object
  Dim a As Variant, a2 As Variant, b As Variant, c As Variant
  Dim i As Long, j As Long, k As Long, n As Long
  Dim ant As Variant, filas As Variant
  
  Set dic = CreateObject("Scripting.Dictionary")
  
  a = Sheets("Sheet1").Range("A1", Sheets("Sheet1").Range("B" & Rows.Count).End(3)).Value
  ReDim a2(1 To UBound(a) + 1, 1 To 2)
  
  b = Sheets("Sheet2").Range("A1", Sheets("Sheet2").Range("D" & Rows.Count).End(3)).Value
  ReDim c(1 To UBound(a) * UBound(b), 1 To 5)
  For i = 2 To UBound(b, 1)
    If Not dic.exists(b(i, 3)) Then Set dic(b(i, 3)) = CreateObject("Scripting.Dictionary")
    dic(b(i, 3))(b(i, 1)) = i
  Next
  For i = 2 To UBound(a, 1)
    If dic.exists(a(i, 2)) Then
      j = j + 1
      a2(j, 1) = a(i, 1)
      a2(j, 2) = a(i, 2)
    End If
  Next

  j = 1
  n = 1
  ant = a2(1, 2)
  Call header1(c, a, j, n)
  For i = 1 To UBound(a2, 1)
    If ant <> a2(i, 2) Then
      j = j + 2
      Call header2(c, b, j, 1)
      j = j + 1
      filas = dic(ant).keys
      For k = 0 To UBound(filas)
        Call header2(c, b, j, filas(k) + 1)
        j = j + 1
      Next
      j = j + 2
      n = n + 1
      If a2(i, 2) <> "" Then Call header1(c, a, j, n)
    End If
    j = j + 1
    c(j, 2) = a2(i, 1)
    c(j, 3) = a2(i, 2)
    ant = a2(i, 2)
  Next
  Sheets("Output").Range("A1").Resize(UBound(c, 1), UBound(c, 2)).Value = c
End Sub

--------------------------------------​
Review which macro is more functional for you.
--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​
 
Upvote 0
Solution
DanteAmor said:
Hello @punnipah .
Thanks for posting on MrExcel board.​

The following macro has reduced code. But maybe it's slow if you have thousands of records in your sheets.
VBA Code: 
Sub FindDataToOutput_v0()
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
  Dim dic As Object, ky As Variant
  Dim c As Range, f As Range
  Dim lr1 As Long, lr2 As Long, lr3 As Long, n As Long
 
  Application.ScreenUpdating = False
 
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  Set sh3 = Sheets("Output")
  Set dic = CreateObject("Scripting.Dictionary")
  lr1 = sh1.Range("B" & Rows.Count).End(3).Row
  lr2 = sh2.Range("C" & Rows.Count).End(3).Row
  sh3.Cells.ClearContents
 
  For Each c In sh1.Range("B2:B" & lr1)
    dic(c.Value) = Empty
  Next
 
  lr3 = 1
  For Each ky In dic.keys
    Set f = sh2.Range("C:C").Find(ky, , xlValues, xlWhole, , , False)
    If Not f Is Nothing Then
      n = n + 1
      sh1.Range("A1:B" & lr1).AutoFilter 2, ky
      sh3.Range("A" & lr3).Value = "No." & n
      sh1.AutoFilter.Range.Copy
      sh3.Range("B" & lr3).PasteSpecial xlPasteValues
      sh2.Range("A1:D" & lr2).AutoFilter 3, ky
      lr3 = sh3.Range("C" & Rows.Count).End(3).Row + 2
      sh2.AutoFilter.Range.Copy
      sh3.Range("B" & lr3).PasteSpecial xlPasteValues
      lr3 = sh3.Range("C" & Rows.Count).End(3).Row + 3
      sh2.Range("A1").AutoFilter
    End If
  Next
  sh1.Range("A1").AutoFilter
  Application.ScreenUpdating = True
End Sub

--------------------------------------​
The following macro is larger, but certainly faster than the previous one, if you have thousands of records.
VBA Code: 
Sub FindDataToOutput_v1()
  Dim dic As Object
  Dim a As Variant, a2 As Variant, b As Variant, c As Variant
  Dim i As Long, j As Long, k As Long, n As Long
  Dim ant As Variant, filas As Variant
 
  Set dic = CreateObject("Scripting.Dictionary")
 
  a = Sheets("Sheet1").Range("A1", Sheets("Sheet1").Range("B" & Rows.Count).End(3)).Value
  ReDim a2(1 To UBound(a) + 1, 1 To 2)
 
  b = Sheets("Sheet2").Range("A1", Sheets("Sheet2").Range("D" & Rows.Count).End(3)).Value
  ReDim c(1 To UBound(a) * UBound(b), 1 To 5)
  For i = 2 To UBound(b, 1)
    If Not dic.exists(b(i, 3)) Then Set dic(b(i, 3)) = CreateObject("Scripting.Dictionary")
    dic(b(i, 3))(b(i, 1)) = i
  Next
  For i = 2 To UBound(a, 1)
    If dic.exists(a(i, 2)) Then
      j = j + 1
      a2(j, 1) = a(i, 1)
      a2(j, 2) = a(i, 2)
    End If
  Next

  j = 1
  n = 1
  ant = a2(1, 2)
  Call header1(c, a, j, n)
  For i = 1 To UBound(a2, 1)
    If ant <> a2(i, 2) Then
      j = j + 2
      Call header2(c, b, j, 1)
      j = j + 1
      filas = dic(ant).keys
      For k = 0 To UBound(filas)
        Call header2(c, b, j, filas(k) + 1)
        j = j + 1
      Next
      j = j + 2
      n = n + 1
      If a2(i, 2) <> "" Then Call header1(c, a, j, n)
    End If
    j = j + 1
    c(j, 2) = a2(i, 1)
    c(j, 3) = a2(i, 2)
    ant = a2(i, 2)
  Next
  Sheets("Output").Range("A1").Resize(UBound(c, 1), UBound(c, 2)).Value = c
End Sub

--------------------------------------​
Review which macro is more functional for you.
--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​
Click to expand...

It's very good. Thank you very much.
 
Upvote 0
DanteAmor said:
Hello @punnipah .
Thanks for posting on MrExcel board.​

The following macro has reduced code. But maybe it's slow if you have thousands of records in your sheets.
VBA Code: 
Sub FindDataToOutput_v0()
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
  Dim dic As Object, ky As Variant
  Dim c As Range, f As Range
  Dim lr1 As Long, lr2 As Long, lr3 As Long, n As Long
 
  Application.ScreenUpdating = False
 
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  Set sh3 = Sheets("Output")
  Set dic = CreateObject("Scripting.Dictionary")
  lr1 = sh1.Range("B" & Rows.Count).End(3).Row
  lr2 = sh2.Range("C" & Rows.Count).End(3).Row
  sh3.Cells.ClearContents
 
  For Each c In sh1.Range("B2:B" & lr1)
    dic(c.Value) = Empty
  Next
 
  lr3 = 1
  For Each ky In dic.keys
    Set f = sh2.Range("C:C").Find(ky, , xlValues, xlWhole, , , False)
    If Not f Is Nothing Then
      n = n + 1
      sh1.Range("A1:B" & lr1).AutoFilter 2, ky
      sh3.Range("A" & lr3).Value = "No." & n
      sh1.AutoFilter.Range.Copy
      sh3.Range("B" & lr3).PasteSpecial xlPasteValues
      sh2.Range("A1:D" & lr2).AutoFilter 3, ky
      lr3 = sh3.Range("C" & Rows.Count).End(3).Row + 2
      sh2.AutoFilter.Range.Copy
      sh3.Range("B" & lr3).PasteSpecial xlPasteValues
      lr3 = sh3.Range("C" & Rows.Count).End(3).Row + 3
      sh2.Range("A1").AutoFilter
    End If
  Next
  sh1.Range("A1").AutoFilter
  Application.ScreenUpdating = True
End Sub

--------------------------------------​
The following macro is larger, but certainly faster than the previous one, if you have thousands of records.
VBA Code: 
Sub FindDataToOutput_v1()
  Dim dic As Object
  Dim a As Variant, a2 As Variant, b As Variant, c As Variant
  Dim i As Long, j As Long, k As Long, n As Long
  Dim ant As Variant, filas As Variant
 
  Set dic = CreateObject("Scripting.Dictionary")
 
  a = Sheets("Sheet1").Range("A1", Sheets("Sheet1").Range("B" & Rows.Count).End(3)).Value
  ReDim a2(1 To UBound(a) + 1, 1 To 2)
 
  b = Sheets("Sheet2").Range("A1", Sheets("Sheet2").Range("D" & Rows.Count).End(3)).Value
  ReDim c(1 To UBound(a) * UBound(b), 1 To 5)
  For i = 2 To UBound(b, 1)
    If Not dic.exists(b(i, 3)) Then Set dic(b(i, 3)) = CreateObject("Scripting.Dictionary")
    dic(b(i, 3))(b(i, 1)) = i
  Next
  For i = 2 To UBound(a, 1)
    If dic.exists(a(i, 2)) Then
      j = j + 1
      a2(j, 1) = a(i, 1)
      a2(j, 2) = a(i, 2)
    End If
  Next

  j = 1
  n = 1
  ant = a2(1, 2)
  Call header1(c, a, j, n)
  For i = 1 To UBound(a2, 1)
    If ant <> a2(i, 2) Then
      j = j + 2
      Call header2(c, b, j, 1)
      j = j + 1
      filas = dic(ant).keys
      For k = 0 To UBound(filas)
        Call header2(c, b, j, filas(k) + 1)
        j = j + 1
      Next
      j = j + 2
      n = n + 1
      If a2(i, 2) <> "" Then Call header1(c, a, j, n)
    End If
    j = j + 1
    c(j, 2) = a2(i, 1)
    c(j, 3) = a2(i, 2)
    ant = a2(i, 2)
  Next
  Sheets("Output").Range("A1").Resize(UBound(c, 1), UBound(c, 2)).Value = c
End Sub

--------------------------------------​
Review which macro is more functional for you.
--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​
Click to expand...

@DanteAmor
i Have 1 Quetion
-Find the next two duplicate values, if one value does not work.

How Should i do Help again

Thank You So much
1684806034751.png
 
Upvote 0
punnipah said:
How to Find 2 or more Working if 1 Data Don't Working
Click to expand...
I don't understand.

Can you explain it with data, as you did in your original post, that is, what data do you have in sheet1, what data do you have in sheet2 and what is the output?


And by the way, which macro are you using?
:cool:
 
Upvote 0
DanteAmor said:
I don't understand.

Can you explain it with data, as you did in your original post, that is, what data do you have in sheet1, what data do you have in sheet2 and what is the output?


And by the way, which macro are you using?
:cool:
Click to expand...
First That'all Good

1. How to find Data in Sheet1
2.Then Vlook up to find the same values in Sheet 2
3.Enter the obtained results into the Sheet output.

But i want to change Step 1 Only
1. How to find Data in Sheet1 (FindOnly 2 or more duplicate entries)
Sheet 1
Datatest.xlsx
ABC
1Merchant IDDevice ID
2230330611Ok
3230330611Ok
4230330275
5230330568
6230330560If one data no need to find value
7230330832Ok
8230330832Ok
9
10
11
12
13
14
15
16
17
18
Sheet1




Sheet 2
Datatest.xlsx
ABCDE
1NoBank LocMobile NoUserID
2186140611AKC
3286140610AKC
4386140560AKC
5486131923AKC
6586131832AKC
7686131832AKC
8
9
10
11
12
13
14
15End of Report
16
17
18
Sheet2



output

Datatest.xlsx
ABCDE
1No.1Merchant IDDevice ID
2230330611
3230330611
4
5NoBank LocMobile NoUserID
6186140611AKC
7
8
9No.2Merchant IDDevice ID
10230330832
11230330832
12
13NoBank LocMobile NoUserID
14586131832AKC
15686131832AKC
16
17 only 2 or more duplicate values
18
19
20
21
output
 
Upvote 0
punnipah said:
1. How to find Data in Sheet1 (FindOnly 2 or more duplicate entries)
Click to expand...
Try this:

VBA Code: 
Sub FindDataToOutput_v0()
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
  Dim dic As Object, ky As Variant
  Dim c As Range, f As Range
  Dim lr1 As Long, lr2 As Long, lr3 As Long, n As Long
  
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  Set sh3 = Sheets("Output")
  Set dic = CreateObject("Scripting.Dictionary")
  lr1 = sh1.Range("B" & Rows.Count).End(3).Row
  lr2 = sh2.Range("C" & Rows.Count).End(3).Row
  sh3.Cells.ClearContents
  
  For Each c In sh1.Range("B2:B" & lr1)
    dic(c.Value) = dic(c.Value) + 1
  Next
  
  lr3 = 1
  For Each ky In dic.keys
    If dic(ky) > 1 Then
      Set f = sh2.Range("C:C").Find(ky, , xlValues, xlWhole, , , False)
      If Not f Is Nothing Then
        n = n + 1
        sh1.Range("A1:B" & lr1).AutoFilter 2, ky
        sh3.Range("A" & lr3).Value = "No." & n
        sh1.AutoFilter.Range.Copy
        sh3.Range("B" & lr3).PasteSpecial xlPasteValues
        sh2.Range("A1:D" & lr2).AutoFilter 3, ky
        lr3 = sh3.Range("C" & Rows.Count).End(3).Row + 2
        sh2.AutoFilter.Range.Copy
        sh3.Range("B" & lr3).PasteSpecial xlPasteValues
        lr3 = sh3.Range("C" & Rows.Count).End(3).Row + 3
        sh2.Range("A1").AutoFilter
      End If
    End If
  Next
  sh1.Range("A1").AutoFilter
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
DanteAmor said:
Try this:

VBA Code: 
Sub FindDataToOutput_v0()
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
  Dim dic As Object, ky As Variant
  Dim c As Range, f As Range
  Dim lr1 As Long, lr2 As Long, lr3 As Long, n As Long
 
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
 
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  Set sh3 = Sheets("Output")
  Set dic = CreateObject("Scripting.Dictionary")
  lr1 = sh1.Range("B" & Rows.Count).End(3).Row
  lr2 = sh2.Range("C" & Rows.Count).End(3).Row
  sh3.Cells.ClearContents
 
  For Each c In sh1.Range("B2:B" & lr1)
    dic(c.Value) = dic(c.Value) + 1
  Next
 
  lr3 = 1
  For Each ky In dic.keys
    If dic(ky) > 1 Then
      Set f = sh2.Range("C:C").Find(ky, , xlValues, xlWhole, , , False)
      If Not f Is Nothing Then
        n = n + 1
        sh1.Range("A1:B" & lr1).AutoFilter 2, ky
        sh3.Range("A" & lr3).Value = "No." & n
        sh1.AutoFilter.Range.Copy
        sh3.Range("B" & lr3).PasteSpecial xlPasteValues
        sh2.Range("A1:D" & lr2).AutoFilter 3, ky
        lr3 = sh3.Range("C" & Rows.Count).End(3).Row + 2
        sh2.AutoFilter.Range.Copy
        sh3.Range("B" & lr3).PasteSpecial xlPasteValues
        lr3 = sh3.Range("C" & Rows.Count).End(3).Row + 3
        sh2.Range("A1").AutoFilter
      End If
    End If
  Next
  sh1.Range("A1").AutoFilter
  Application.ScreenUpdating = True
End Sub
Click to expand...

Awesome!! Thank you So much
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
How to compare 2 different excel sheets and output results on 3rd sheet
Replies
3
Views
158
Peter_SSs
Peter_SSs
P
  • Question
Automating copying of columns within same sheet in excel using VBA.
Replies
1
Views
171
MountainFog
M
B
  • Solved
VBA Help - Same Function needed for multiple sheets
Replies
2
Views
263
birdman15
B
H
  • Question
data extract between sheets For the value entered
Replies
1
Views
161
LazyBug
LazyBug
P
  • Question
How to find a word then cross reference to see if match
Replies
0
Views
299
Patriot2879
P

Forum statistics

Threads
1,215,438
Messages
6,124,873
Members
449,192
Latest member
MoonDancer

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top