VBA: Copy cell content based on Value

NeoSez

Board Regular
Joined
Aug 14, 2020
Messages
89
Office Version
  1. 2010
Platform
  1. Windows
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!!

VBA Code:
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
 

Attachments

  • Update sheets.JPG
    Update sheets.JPG
    124.1 KB · Views: 14

Some videos you may like

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
You could explain with your examples what you need.
In your images you have 4 examples, could you explain what you need.
 

NeoSez

Board Regular
Joined
Aug 14, 2020
Messages
89
Office Version
  1. 2010
Platform
  1. Windows
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.

update2.JPG
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
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
ABCDE
212345601-jul
312345702-julreceived07-mar
412345803-jul
512345904-julin progress
612346005-jul
712346106-jul
8123462
9123463
10123464
Sheet1


Sheet2:
varios 04sep2020.xlsm
FGHIJKLMN
1TrackingGHIDate ReceivedKLMStatus
21234567/12/2020 receivedReceived
31234597/14/2020 deliveredDel
412346007/13/2020 was receivedReceived
512346107/14/2020 deliveredDel
61234627/16/2020 picked upIn prog
71234637/17/2020 picked upIn prog
8123464picked up 7/15/2020In prog
91234657/15/2020 picked upIn prog
101234667/18/2020 picked upIn prog
11
Sheet2


Sheet1 after macro:
varios 04sep2020.xlsm
ABCDE
212345601-jul7/12/2020 received
312345702-julreceived07-mar
412345803-jul
512345904-julin progress7/14/2020 delivered
612346005-jul07/13/2020 was received
712346106-jul07/14/2020 delivered
81234627/16/2020 picked up
91234637/17/2020 picked up
10123464picked up 7/15/2020
111234657/15/2020 picked up
121234667/18/2020 picked up
Sheet1


VBA Code:
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

Board Regular
Joined
Aug 14, 2020
Messages
89
Office Version
  1. 2010
Platform
  1. Windows

ADVERTISEMENT

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

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
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

Board Regular
Joined
Aug 14, 2020
Messages
89
Office Version
  1. 2010
Platform
  1. Windows

ADVERTISEMENT

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

Board Regular
Joined
Aug 14, 2020
Messages
89
Office Version
  1. 2010
Platform
  1. Windows
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
ABCDE
212345601-jul
312345702-julreceived07-mar
412345803-jul
512345904-julin progress
612346005-jul
712346106-jul
8123462
9123463
10123464
Sheet1


Sheet2:
varios 04sep2020.xlsm
FGHIJKLMN
1TrackingGHIDate ReceivedKLMStatus
21234567/12/2020 receivedReceived
31234597/14/2020 deliveredDel
412346007/13/2020 was receivedReceived
512346107/14/2020 deliveredDel
61234627/16/2020 picked upIn prog
71234637/17/2020 picked upIn prog
8123464picked up 7/15/2020In prog
91234657/15/2020 picked upIn prog
101234667/18/2020 picked upIn prog
11
Sheet2


Sheet1 after macro:
varios 04sep2020.xlsm
ABCDE
212345601-jul7/12/2020 received
312345702-julreceived07-mar
412345803-jul
512345904-julin progress7/14/2020 delivered
612346005-jul07/13/2020 was received
712346106-jul07/14/2020 delivered
81234627/16/2020 picked up
91234637/17/2020 picked up
10123464picked up 7/15/2020
111234657/15/2020 picked up
121234667/18/2020 picked up
Sheet1


VBA Code:
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

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
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
ABCDE
112345
Sheet1

varios 04sep2020.xlsm
FGHIJKLMNO
112345678910
Sheet2


VBA Code:
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

Board Regular
Joined
Aug 14, 2020
Messages
89
Office Version
  1. 2010
Platform
  1. Windows
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
ABCDE
112345
Sheet1

varios 04sep2020.xlsm
FGHIJKLMNO
112345678910
Sheet2


VBA Code:
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.

VBA Code:
 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)
 

Watch MrExcel Video

Forum statistics

Threads
1,114,010
Messages
5,545,479
Members
410,685
Latest member
chandraganji
Top