VBA: Copy cell content based on Value

NeoSez

Board Regular
Joined
Aug 14, 2020
Messages
210
Office Version
  1. 2019
  2. 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: 16
One more question: When copying from SHEET2 COL J COPY TO---> SHEET1 COL D , will it clear the contents currently in SHEET1 COL D? If not, can you add a line to clear the contents of that cell? Thank you.
 
Upvote 0

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"
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

Hello @DanteAmor.
I am struggling with this section. I don't quite understand this.
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)

If I want to change from:
SHEET2 COL F COPY TO---> SHEET1 COL A
SHEET2 COL J COPY TO---> SHEET1 COL D
SHEET2 COL H COPY TO---> SHEET1 COL C

...to this, then how would the above formula look? Thank you in advance.
SHEET2 COL L COPY TO---> SHEET1 COL A
SHEET2 COL AR COPY TO---> SHEET1 COL I
SHEET2 COL X COPY TO---> SHEET1 COL C
 
Upvote 0
Hello @DanteAmor.
I have made some changes...

BEFORE:
SHEET2 COL F COPY TO---> SHEET1 COL A c(k, 1) = b(i, 1)
SHEET2 COL J COPY TO---> SHEET1 COL D c(k, 4) = b(i, 5)
SHEET2 COL N COPY TO--->SHEET1 COL C c(k, 3) = b(i, 3)

NOW:
SHEET2 COL F COPY TO---> SHEET1 COL A c(k, 6) = b(i, 1)
SHEET2 COL T COPY TO---> SHEET1 COL I c(k, 20) = b(i, 9)
SHEET2 COL X COPY TO---> SHEET1 COL C c(k, 24) = b(i, 3)

ERROR:
"Compile Error: Syntax Error" :(
What is wrong with the code?
Thank you in advance!

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:I" & 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, 6) = b(i, 1)
        c(k, 20) = b(i, 9)
        c(k, 24) = b(i, 3)

    Else
      a(dic(b(i, 1)), 4) = b(i, 5)
    End If
  Next
  
  sh1.Range("G2").Resize(UBound(a, )), 1).Value = Application.Index(a, , 9)
  sh1.Range("A" & Rows.Count).End(3)(2).Resize(k, UBound(b, 2)).Value = c
End Sub
 
Upvote 0

Forum statistics

Threads
1,213,544
Messages
6,114,249
Members
448,556
Latest member
peterhess2002

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