VBA: Copy cell content based on Value

[NeoSez]

Hello, I am new and was hoping someone could help me.
I have this awesome code and want to add some code to extract new updates from Sheet2 col "T", based on col "F" ---> Sheet1 Col "C" & "A" respectively.
So,
Sheet2 col "T", => Sheet1 Col "C"

Sheet2 col "F" => Sheet1 Col "A"

Thank you!!

Sub test3()
Dim fullstr As String
With Worksheets("Sheet2")
lastup = .Cells(Rows.Count, "F").End(xlUp).Row ' find last row in column F of sheet 2
updt = Range(.Cells(1, 1), .Cells(lastup, 24)) ' pick columns A to X and all rows in sheet 2
' new mapping G is now F column 6
' H  is now X column 24
'I is now T column 20 Date is assumed to be all the characters up to the first space
End With
Worksheets("Sheet1").Select      ' lots of people say don't use select  but doing it once is quick and easy!!
lastmast = Cells(Rows.Count, "A").End(xlUp).Row
mastarr = Range(Cells(1, 1), Cells(lastmast, 4))

For i = 2 To lastmast
For j = 2 To lastup
  If mastarr(i, 1) = updt(j, 6) Then ' Column F
  mastarr(i, 3) = updt(j, 24) ' update status for all rows
  ' convert update status to upper case for comparison
   sts = StrConv(updt(j, 24), vbUpperCase)
  If sts = "DELIVERED" Or sts = "RECEIVED" Then
   fullstr = updt(j, 20) ' Column T
    startstr = -1
    endstr = Len(fullstr)
    For kk = 1 To Len(fullstr)
        digt = Mid(fullstr, kk, 1)
        If IsNumeric(digt) And startstr < 0 Then ' check for the first number in the string
           startstr = kk   ' set this to start of the string
        End If
        digasc = Asc(digt)   ' convert the curent character to ascii
        If startstr > 0 And (digasc > 57 Or digasc < 47) Then ' this checks whether the digit is a number or /
         endstr = kk ' set then end of the string as the first character which isn't a number or a slash
         Exit For
        End If
    Next kk
      If startstr > 0 Then
      dt = Mid(fullstr, startstr, endstr - startstr + 1)
      mastarr(i, 4) = dt
      End If
  End If
  End If
Next j
Next i
Range(Cells(1, 1), Cells(lastmast, 4)) = mastarr
End Sub

 

[DanteAmor]

You could explain with your examples what you need.
In your images you have 4 examples, could you explain what you need.

 

[NeoSez]

You could explain with your examples what you need.
In your images you have 4 examples, could you explain what you need.

Hello DanteAmor. Thank you for your reply.
I have included a new diagram to explain what I am trying to achieve. I hope it's explained clear enough so that you can help. Thank you.
Please see diagram.

 

[DanteAmor]

In this case, 123465 is not on sheet1, therefore, copy entire row into sheet1 starting at row11

But if I copy the entire row, column J will not match column D, column J from sheet 2 will be column E from sheet1.
But if that's okay for you, try the following:

Sheet1 before macro:

varios 04sep2020.xlsm
	A	B	C	D	E
2	123456	01-jul
3	123457	02-jul	received	07-mar
4	123458	03-jul
5	123459	04-jul	in progress
6	123460	05-jul
7	123461	06-jul
8	123462
9	123463
10	123464
Sheet1

Sheet2:

varios 04sep2020.xlsm
	F	G	H	I	J	K	L	M	N
1	Tracking	G	H	I	Date Received	K	L	M	Status
2	123456				7/12/2020 received				Received
3	123459				7/14/2020 delivered				Del
4	123460				07/13/2020 was received				Received
5	123461				07/14/2020 delivered				Del
6	123462				7/16/2020 picked up				In prog
7	123463				7/17/2020 picked up				In prog
8	123464				picked up 7/15/2020				In prog
9	123465				7/15/2020 picked up				In prog
10	123466				7/18/2020 picked up				In prog
11
Sheet2

Sheet1 after macro:

varios 04sep2020.xlsm
	A	B	C	D	E
2	123456	01-jul		7/12/2020 received
3	123457	02-jul	received	07-mar
4	123458	03-jul
5	123459	04-jul	in progress	7/14/2020 delivered
6	123460	05-jul		07/13/2020 was received
7	123461	06-jul		07/14/2020 delivered
8	123462			7/16/2020 picked up
9	123463			7/17/2020 picked up
10	123464			picked up 7/15/2020
11	123465				7/15/2020 picked up
12	123466				7/18/2020 picked up
Sheet1

Sub Tracking_Update()
  Dim a As Variant, b As Variant, c As Variant
  Dim dic As Object, sh1 As Worksheet
  Dim i As Long, j As Long, k As Long
  
  Set sh1 = Sheets("Sheet1")
  Set dic = CreateObject("Scripting.Dictionary")
  
  a = sh1.Range("A2:D" & sh1.Range("A" & Rows.Count).End(3).Row).Value2
  b = Sheets("Sheet2").Range("F2", Sheets("Sheet2").Cells.SpecialCells(xlCellTypeLastCell)).Value2
  ReDim c(1 To UBound(b, 1), 1 To UBound(b, 2))
  
  For i = 1 To UBound(a, 1)
    dic(a(i, 1)) = i
  Next

  For i = 1 To UBound(b, 1)
    If Not dic.exists(b(i, 1)) Then
      k = k + 1
      For j = 1 To UBound(b, 2)
        c(k, j) = b(i, j)
      Next
    Else
      a(dic(b(i, 1)), 4) = b(i, 5)
    End If
  Next
  
  sh1.Range("D2").Resize(UBound(a, 1), 1).Value = Application.Index(a, , 4)
  sh1.Range("A" & Rows.Count).End(3)(2).Resize(k, UBound(b, 2)).Value = c
End Sub

 

[NeoSez]

Thank you DanteAmor. The formula works great, however, is it possible to only copy the corresponding cell to the appropriate cell so that it will all match? How to copy cell content?

 

[DanteAmor]

is it possible to only copy the corresponding cell to the appropriate cell so that it will all match?

How do I identify which one goes into which?
You want to copy the entire row from sheet2 and paste on sheet1.
How many columns are on sheet2? which column on sheet2 corresponds to which column on sheet1.

 

[NeoSez]

DanteAmor, for the purpose of this exercise, just the following 3 columns to copy. I will try to figure out the remainder on my own. Thank you!

SHEET2 COL F COPY TO---> SHEET1 COL A
SHEET2 COL J COPY TO---> SHEET1 COL D
SHEET2 COL H COPY TO--->SHEET1 COL C

 

[NeoSez]

But if I copy the entire row, column J will not match column D, column J from sheet 2 will be column E from sheet1.
But if that's okay for you, try the following:

Sheet1 before macro:

varios 04sep2020.xlsm
	A	B	C	D	E
2	123456	01-jul
3	123457	02-jul	received	07-mar
4	123458	03-jul
5	123459	04-jul	in progress
6	123460	05-jul
7	123461	06-jul
8	123462
9	123463
10	123464
Sheet1

Sheet2:

varios 04sep2020.xlsm
	F	G	H	I	J	K	L	M	N
1	Tracking	G	H	I	Date Received	K	L	M	Status
2	123456				7/12/2020 received				Received
3	123459				7/14/2020 delivered				Del
4	123460				07/13/2020 was received				Received
5	123461				07/14/2020 delivered				Del
6	123462				7/16/2020 picked up				In prog
7	123463				7/17/2020 picked up				In prog
8	123464				picked up 7/15/2020				In prog
9	123465				7/15/2020 picked up				In prog
10	123466				7/18/2020 picked up				In prog
11
Sheet2

Sheet1 after macro:

varios 04sep2020.xlsm
	A	B	C	D	E
2	123456	01-jul		7/12/2020 received
3	123457	02-jul	received	07-mar
4	123458	03-jul
5	123459	04-jul	in progress	7/14/2020 delivered
6	123460	05-jul		07/13/2020 was received
7	123461	06-jul		07/14/2020 delivered
8	123462			7/16/2020 picked up
9	123463			7/17/2020 picked up
10	123464			picked up 7/15/2020
11	123465				7/15/2020 picked up
12	123466				7/18/2020 picked up
Sheet1

Sub Tracking_Update()
  Dim a As Variant, b As Variant, c As Variant
  Dim dic As Object, sh1 As Worksheet
  Dim i As Long, j As Long, k As Long
 
  Set sh1 = Sheets("Sheet1")
  Set dic = CreateObject("Scripting.Dictionary")
 
  a = sh1.Range("A2:D" & sh1.Range("A" & Rows.Count).End(3).Row).Value2
  b = Sheets("Sheet2").Range("F2", Sheets("Sheet2").Cells.SpecialCells(xlCellTypeLastCell)).Value2
  ReDim c(1 To UBound(b, 1), 1 To UBound(b, 2))
 
  For i = 1 To UBound(a, 1)
    dic(a(i, 1)) = i
  Next

  For i = 1 To UBound(b, 1)
    If Not dic.exists(b(i, 1)) Then
      k = k + 1
      For j = 1 To UBound(b, 2)
        c(k, j) = b(i, j)
      Next
    Else
      a(dic(b(i, 1)), 4) = b(i, 5)
    End If
  Next
 
  sh1.Range("D2").Resize(UBound(a, 1), 1).Value = Application.Index(a, , 4)
  sh1.Range("A" & Rows.Count).End(3)(2).Resize(k, UBound(b, 2)).Value = c
End Sub

How do you copy the chart into the post?

 

[DanteAmor]

This is the relationship of columns on each sheet. To paste a range of cells here use XL2BB tool, see my signature.

varios 04sep2020.xlsm
	A	B	C	D	E
1	1	2	3	4	5
Sheet1

varios 04sep2020.xlsm
	F	G	H	I	J	K	L	M	N	O
1	1	2	3	4	5	6	7	8	9	10
Sheet2

Sub Tracking_Update()
  Dim a As Variant, b As Variant, c As Variant
  Dim dic As Object, sh1 As Worksheet
  Dim i As Long, j As Long, k As Long
  
  Set sh1 = Sheets("Sheet1")
  Set dic = CreateObject("Scripting.Dictionary")
  
  a = sh1.Range("A2:D" & sh1.Range("A" & Rows.Count).End(3).Row).Value2
  b = Sheets("Sheet2").Range("F2", Sheets("Sheet2").Cells.SpecialCells(xlCellTypeLastCell)).Value2
  ReDim c(1 To UBound(b, 1), 1 To UBound(b, 2))
  
  For i = 1 To UBound(a, 1)
    dic(a(i, 1)) = i
  Next

  For i = 1 To UBound(b, 1)
    If Not dic.exists(b(i, 1)) Then
      k = k + 1
      c(k, 1) = b(i, 1)
      c(k, 4) = b(i, 5)
      c(k, 3) = b(i, 3)
    Else
      a(dic(b(i, 1)), 4) = b(i, 5)
    End If
  Next
  
  sh1.Range("D2").Resize(UBound(a, 1), 1).Value = Application.Index(a, , 4)
  sh1.Range("A" & Rows.Count).End(3)(2).Resize(k, UBound(b, 2)).Value = c
End Sub

 

[NeoSez]

This is the relationship of columns on each sheet. To paste a range of cells here use XL2BB tool, see my signature.

varios 04sep2020.xlsm
	A	B	C	D	E
1	1	2	3	4	5
Sheet1

varios 04sep2020.xlsm
	F	G	H	I	J	K	L	M	N	O
1	1	2	3	4	5	6	7	8	9	10
Sheet2

Sub Tracking_Update()
  Dim a As Variant, b As Variant, c As Variant
  Dim dic As Object, sh1 As Worksheet
  Dim i As Long, j As Long, k As Long
 
  Set sh1 = Sheets("Sheet1")
  Set dic = CreateObject("Scripting.Dictionary")
 
  a = sh1.Range("A2:D" & sh1.Range("A" & Rows.Count).End(3).Row).Value2
  b = Sheets("Sheet2").Range("F2", Sheets("Sheet2").Cells.SpecialCells(xlCellTypeLastCell)).Value2
  ReDim c(1 To UBound(b, 1), 1 To UBound(b, 2))
 
  For i = 1 To UBound(a, 1)
    dic(a(i, 1)) = i
  Next

  For i = 1 To UBound(b, 1)
    If Not dic.exists(b(i, 1)) Then
      k = k + 1
      c(k, 1) = b(i, 1)
      c(k, 4) = b(i, 5)
      c(k, 3) = b(i, 3)
    Else
      a(dic(b(i, 1)), 4) = b(i, 5)
    End If
  Next
 
  sh1.Range("D2").Resize(UBound(a, 1), 1).Value = Application.Index(a, , 4)
  sh1.Range("A" & Rows.Count).End(3)(2).Resize(k, UBound(b, 2)).Value = c
End Sub

DanteAmor
Thank you!

That tool is awesome! I will be using it next time.

The script works really well too!!! Thank you.
I was trying to understand each line. Ubound is a new term for me.
Is this the section that refers to what cell is updated? What if I want to change to different cells? I was trying to figure out what corresponds with what cell and sheet. Thanks for the explanation to help me better understand and learn.

 For i = 1 To UBound(b, 1)
    If Not dic.exists(b(i, 1)) Then
      k = k + 1
      c(k, 1) = b(i, 1)
      c(k, 4) = b(i, 5)
      c(k, 3) = b(i, 3)
    Else
      a(dic(b(i, 1)), 4) = b(i, 5)