Macro to Find and paste the cell value

D

Daddy143

New Member
Joined
Dec 10, 2018
Messages
14
Hello,

I'm newbie to Excel. i need your help. i have a file and i want data from sheet2 to sheet1.

Ex:
1. Sheet2 - Row A-King of Row-Civil: 10/3/2018 will be copied in sheet of E17 cell.
2. Sheet2 - Row A-Kitsap of Row-Civil: 10/3/2018 will be copied in sheet of E18 cell.
and this will repeat to last Row to Column.

https://www.dropbox.com/s/kd0ndz0jijzxxlx/PNWcourtwork (1).xlsm?dl=0

Can someone help with it?

thanks in advance....
 

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
Sort by date Sort by votes
Try:
Code: 
Sub PasteCellValue()
    Application.ScreenUpdating = False
    Dim LastRow As Long, civil As Range, rName As Range, sAddr As String
    LastRow = Sheets("Sheet2").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With Sheets("Sheet2").Range("B2:B" & LastRow)
        Set civil = .Find("civil:", LookIn:=xlValues, LookAt:=xlPart)
        If Not civil Is Nothing Then
            sAddr = civil.Address
            Do
                Set rName = Sheets("Sheet1").Range("B:B").Find(civil.Offset(-1, -1).Value)
                If Not rName Is Nothing Then
                    rName.Offset(0, 3) = civil.Offset(0, 2)
                End If
                Set civil = .Find("civil:", after:=civil, LookIn:=xlValues, LookAt:=xlWhole)
            Loop While civil.Address <> sAddr
            sAddr = ""
        End If
    End With
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Thank you so much for quick reply.

This works fine for me, but i want to run a VBA for all the Header values in Sheet1 i.e "JDG, CIVIL, PROBATE, BKY(in sheet2 we can find word [Bankruptcy], FEDJDG(in sheet2 we can find word [FDG] & LIENS".

I worked around for "JDG" with your given code and replacing all 'Civil' to 'JDG' and also changing '.Offset(-1, -1).Value to '.Offset(-4, -1).Value, i'm getting the result and i can modify for all headers (Above mentioned). my request is do we run a code in a single sub procedure (because we have to write 6 sub procedures to achieve this). and also i need a 'YELLOW' colour should be highlighted what are the data changes through VBA if not changes no colour should be there.
 
Upvote 0
One macro should be able to do all you want. However, the problem is that the values in Sheet2 don't all match the headers in Sheet1. Sheet2 contains civil:, domestic:, probate:, JDG:, JDGMOD: and JDGREL: Sheet1 contains JDG, CIVILS, PROBATES, BKY, FEDJDG and Liens. "CIVILS" corresponds to "civil:", "PROBATES" correspond to "probate:", "JDG" corresponds to "LDG". What do domestic:, JDGMOD: and JDGREL: correspond to? If you could make the two ranges match exactly, that would solve the problem. Also please clarify in detail what you mean by:
I need a 'YELLOW' colour should be highlighted what are the data changes through VBA if not changes no colour should be there.
Click to expand...
Refer to specific cells, rows, columns and sheets using a few examples from your data.
 
Upvote 0
Thank you mumps

below are the requirements:

BKY(Sheet1) corresponds to 'Bankruptcy' in sheet2 of 'B131' cell.

FEDJDG(Sheet1) corresponds to 'FDG' in sheet2 of 'B139, B146, B153 & B160' cell and rest headers are not needed now.

by example we find civil in sheet2 date xx/xx/xxxx (Month/Date/Year) and pasting that value in sheet1 of E17(cell) these cells should be highlight in Yellow colour.
and if the cell value not changes no colour format needed.
 
Upvote 0
'B139, B146, B153 & B160' of Sheet2 don't contain 'FDG' and 'B131' doesn't contain 'Bankruptcy'. Also, I don't see any date associated with 'Bankruptcy' in Sheet2. Please clarify.
 
Upvote 0
Sorry for the confusion.

Below are the details.

FDG contains in cell B138, B145, B152 & B159.

Bankruptcy contains in Cell B130 and date associated details are
1. Sheet2 - Row A-King (A131) & date shown in cell D131
2. Sheet2 - Row A-Pierce (A132) & date shown in cell D132
3. Sheet2 - Row A-Spokane (A133) & date shown in cell D133
4. Sheet2 - Row A-Lane (A134) & date shown in cell D134


 
Upvote 0
This macro will take care of columns D:H in Sheet1. It assumes that "Bankruptcy" in Sheet2 will always have 4 dates in column D associated with it.
Code: 
Sub PasteCellValue()
    Application.ScreenUpdating = False
    Dim rng As Range, rName1 As Range, rName2 As Range, sAddr As String, x As Long
    For Each rng In Sheets("Sheet1").Range("D1:H1")
        Select Case rng.Value
            Case "JDG"
                Set rName1 = Sheets("Sheet2").Range("B:B").Find("JDG:", LookIn:=xlValues, lookat:=xlWhole)
                If Not rName1 Is Nothing Then
                    sAddr = rName1.Address
                    Do
                        Set rName2 = Sheets("Sheet1").Range("B:B").Find(rName1.Offset(-4, -1).Value)
                        If Not rName2 Is Nothing And Sheets("Sheet1").Cells(rName2.Row, rng.Column) <> rName1.Offset(0, 2) Then
                            Sheets("Sheet1").Cells(rName2.Row, rng.Column) = rName1.Offset(0, 2)
                        End If
                        Set rName1 = Sheets("Sheet2").Range("B:B").Find("JDG:", after:=rName1, LookIn:=xlValues, lookat:=xlWhole)
                    Loop While rName1.Address <> sAddr
                    sAddr = ""
                End If
            Case "CIVILS"
                Set rName1 = Sheets("Sheet2").Range("B:B").Find("civil:", LookIn:=xlValues, lookat:=xlWhole)
                If Not rName1 Is Nothing Then
                    sAddr = rName1.Address
                    Do
                        Set rName2 = Sheets("Sheet1").Range("B:B").Find(rName1.Offset(-1, -1).Value)
                        If Not rName2 Is Nothing And Sheets("Sheet1").Cells(rName2.Row, rng.Column) <> rName1.Offset(0, 2) Then
                            Sheets("Sheet1").Cells(rName2.Row, rng.Column) = rName1.Offset(0, 2)
                        End If
                        Set rName1 = Sheets("Sheet2").Range("B:B").Find("civil:", after:=rName1, LookIn:=xlValues, lookat:=xlWhole)
                    Loop While rName1.Address <> sAddr
                    sAddr = ""
                End If
            Case "PROBATES"
                Set rName1 = Sheets("Sheet2").Range("B:B").Find("probate:", LookIn:=xlValues, lookat:=xlWhole)
                If Not rName1 Is Nothing Then
                    sAddr = rName1.Address
                    Do
                        Set rName2 = Sheets("Sheet1").Range("B:B").Find(rName1.Offset(-3, -1).Value)
                        If Not rName2 Is Nothing And Sheets("Sheet1").Cells(rName2.Row, rng.Column) <> rName1.Offset(0, 2) Then
                            Sheets("Sheet1").Cells(rName2.Row, rng.Column) = rName1.Offset(0, 2)
                        End If
                        Set rName1 = Sheets("Sheet2").Range("B:B").Find("probate:", after:=rName1, LookIn:=xlValues, lookat:=xlWhole)
                    Loop While rName1.Address <> sAddr
                    sAddr = ""
                End If
            Case "BKY"
                Set rName1 = Sheets("Sheet2").Range("B:B").Find("Bankruptcy", LookIn:=xlValues, lookat:=xlWhole)
                If Not rName1 Is Nothing Then
                    For x = 1 To 4
                        Set rName2 = Sheets("Sheet1").Range("B:B").Find(rName1.Offset(x, -1).Value)
                        If Not rName2 Is Nothing And Sheets("Sheet1").Cells(rName2.Row, rng.Column) <> rName1.Offset(x, 2) Then
                            Sheets("Sheet1").Cells(rName2.Row, rng.Column) = rName1.Offset(x, 2)
                        End If
                    Next x
                End If
            Case "FEDJDG"
                Set rName1 = Sheets("Sheet2").Range("B:B").Find("FDG:", LookIn:=xlValues, lookat:=xlWhole)
                If Not rName1 Is Nothing Then
                    sAddr = rName1.Address
                    Do
                        Set rName2 = Sheets("Sheet1").Range("B:B").Find(rName1.Offset(-1, -1).Value)
                        If Not rName2 Is Nothing And Sheets("Sheet1").Cells(rName2.Row, rng.Column) <> rName1.Offset(0, 2) Then
                            Sheets("Sheet1").Cells(rName2.Row, rng.Column) = rName1.Offset(0, 2)
                        End If
                        Set rName1 = Sheets("Sheet2").Range("B:B").Find("FDG:", after:=rName1, LookIn:=xlValues, lookat:=xlWhole)
                    Loop While rName1.Address <> sAddr
                    sAddr = ""
                End If
            
        End Select
    Next rng
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Thank you so much. Looks perfect.


Actually we receive an email on daily basis and we have to update those dates in respective columns D:H in Sheet1. we copied email data in to sheet2.

i need more requirements.
1. No colour format in sheet1.
2. There should be a condition(check point) need to apply. for Example in Sheet2 - Row A-King (A131) TODAY date shown as 12/10/2018, if TOMORROW same date 12/10/2018 available no need to add the cell value(i.e date) in sheet1, if date day after tomorrow (and so on) not matches only update the cell value (i.e date 12/11/2018 or xx/xx/xxxx) in sheet1 and here we have to apply colour format(YELLOW). Some times the dates are not changes on daily basis.

 
Upvote 0
Try:
Code: 
Sub PasteCellValue()
    Application.ScreenUpdating = False
    Dim rng As Range, rName1 As Range, rName2 As Range, sAddr As String, x As Long, sh1 As Worksheet, sh2 As Worksheet
    Set sh1 = Sheets("Sheet1")
    Set sh2 = Sheets("Sheet2")
    For Each rng In sh1.Range("D1:H1")
        Select Case rng.Value
            Case "JDG"
                Set rName1 = sh2.Range("B:B").Find("JDG:", LookIn:=xlValues, lookat:=xlWhole)
                If Not rName1 Is Nothing Then
                    sAddr = rName1.Address
                    Do
                        Set rName2 = sh1.Range("B:B").Find(rName1.Offset(-4, -1).Value)
                        If Not rName2 Is Nothing And sh1.Cells(rName2.Row, rng.Column) <> rName1.Offset(0, 2) Then
                            With sh1
                                .Cells(rName2.Row, rng.Column) = rName1.Offset(0, 2)
                                .Cells(rName2.Row, rng.Column).Interior.ColorIndex = 6
                            End With
                        End If
                        Set rName1 = sh2.Range("B:B").Find("JDG:", after:=rName1, LookIn:=xlValues, lookat:=xlWhole)
                    Loop While rName1.Address <> sAddr
                    sAddr = ""
                End If
            Case "CIVILS"
                Set rName1 = sh2.Range("B:B").Find("civil:", LookIn:=xlValues, lookat:=xlWhole)
                If Not rName1 Is Nothing Then
                    sAddr = rName1.Address
                    Do
                        Set rName2 = sh1.Range("B:B").Find(rName1.Offset(-1, -1).Value)
                        If Not rName2 Is Nothing And sh1.Cells(rName2.Row, rng.Column) <> rName1.Offset(0, 2) Then
                            With sh1
                                .Cells(rName2.Row, rng.Column) = rName1.Offset(0, 2)
                                .Cells(rName2.Row, rng.Column).Interior.ColorIndex = 6
                            End With
                        End If
                        Set rName1 = sh2.Range("B:B").Find("civil:", after:=rName1, LookIn:=xlValues, lookat:=xlWhole)
                    Loop While rName1.Address <> sAddr
                    sAddr = ""
                End If
            Case "PROBATES"
                Set rName1 = sh2.Range("B:B").Find("probate:", LookIn:=xlValues, lookat:=xlWhole)
                If Not rName1 Is Nothing Then
                    sAddr = rName1.Address
                    Do
                        Set rName2 = sh1.Range("B:B").Find(rName1.Offset(-3, -1).Value)
                        If Not rName2 Is Nothing And sh1.Cells(rName2.Row, rng.Column) <> rName1.Offset(0, 2) Then
                            With sh1
                                .Cells(rName2.Row, rng.Column) = rName1.Offset(0, 2)
                                .Cells(rName2.Row, rng.Column).Interior.ColorIndex = 6
                            End With
                        End If
                        Set rName1 = sh2.Range("B:B").Find("probate:", after:=rName1, LookIn:=xlValues, lookat:=xlWhole)
                    Loop While rName1.Address <> sAddr
                    sAddr = ""
                End If
            Case "BKY"
                Set rName1 = sh2.Range("B:B").Find("Bankruptcy", LookIn:=xlValues, lookat:=xlWhole)
                If Not rName1 Is Nothing Then
                    For x = 1 To 4
                        Set rName2 = sh1.Range("B:B").Find(rName1.Offset(x, -1).Value)
                        If Not rName2 Is Nothing And sh1.Cells(rName2.Row, rng.Column) <> rName1.Offset(x, 2) Then
                            With sh1
                                .Cells(rName2.Row, rng.Column) = rName1.Offset(x, 2)
                                .Cells(rName2.Row, rng.Column).Interior.ColorIndex = 6
                            End With
                        End If
                    Next x
                End If
            Case "FEDJDG"
                Set rName1 = sh2.Range("B:B").Find("FDG:", LookIn:=xlValues, lookat:=xlWhole)
                If Not rName1 Is Nothing Then
                    sAddr = rName1.Address
                    Do
                        Set rName2 = sh1.Range("B:B").Find(rName1.Offset(-1, -1).Value)
                        If Not rName2 Is Nothing And sh1.Cells(rName2.Row, rng.Column) <> rName1.Offset(0, 2) Then
                            With sh1
                                .Cells(rName2.Row, rng.Column) = rName1.Offset(0, 2)
                                .Cells(rName2.Row, rng.Column).Interior.ColorIndex = 6
                            End With
                        End If
                        Set rName1 = sh2.Range("B:B").Find("FDG:", after:=rName1, LookIn:=xlValues, lookat:=xlWhole)
                    Loop While rName1.Address <> sAddr
                    sAddr = ""
                End If
            
        End Select
    Next rng
    Application.ScreenUpdating = True
End Sub
I also fixed an error I hadn't noticed before.
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question
VBA Check if value in Sheet1 exists in Sheet2 then copy specific cells from Sheet2 into Sheet1
2
Replies
13
Views
734
dermie_72
D
B
  • Question
Matching Multiple Header Row Cell Values - Copy the data below to next available row.
Replies
2
Views
221
B-radK
B
D
  • Solved
Copy row based on cell value and paste as text in another worksheet
Replies
2
Views
479
DH937
D
Z
  • Solved
Insert (paste) multiple rows below a user-selected cell
Replies
4
Views
472
zankzank
Z
S
  • Question
Copy a column value when the values match to multiple sheets of the workbook
Replies
1
Views
234
sofas
S

Forum statistics

Threads
1,214,974
Messages
6,122,536
Members
449,088
Latest member
RandomExceller01

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