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

NeoSez

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

Some videos you may like

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.

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

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
 

NeoSez

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

Watch MrExcel Video

Forum statistics

Threads
1,114,010
Messages
5,545,477
Members
410,686
Latest member
chandraganji
Top