I have Certificates document that when I enter a repair code into column B it will then vlookup the details from that repair code from a database table. Currently I have the Vlookup formulas in ea of the cells but I want the data when writing the Certificate to remain as it is at that point and if the database changes then the certficate changes which I dont want so I have written the macro below which almost does exactly what I want just a few issues.
On Sh2 I have a helper row that is getting Tool Calibration data from all over another document including tool serial number, tool description and calibration due date. I have roughly 100 cells of data that needs to come in Row T through to Row ~DT is there a way I can do this in like 1 line of code instead of 100 lines changing ea range by 1 at a time.
After all of the vlookups are done I would like Column "A" to autofill down from the last row in "A" down to the last row of "B". I cant do it always from A2:A because sometimes in the odd occasion we need to a line in to redo a certificate and call it the same report with a B at the end and it will over write that and make all the next numbers wrong.
Thanks in advance, Todd
Sub Autofill()
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet
Dim MyVariable As Variant
Dim rng As Range
Dim Last_Row As Single
Dim Last_Row2 As Single
Set Sh1 = Sheets("Certificates") '<-The sheet that you test B for TRUE
Set Sh2 = Sheets("Codes") '<- The sheet for the vlookup range
Last_Row = Sh1.Range("B" & Rows.Count).End(xlUp).Row
Last_Row2 = Sh1.Range("A" & Rows.Count).End(xlUp).Row
For Each rng In Sh1.Range("B2:B" & Last_Row)
If rng > 0 And Cells(rng.Row, "E").Value = 0 Then
Cells(rng.Row, "E").Value = Application.VLookup(rng, Sh2.Range("$A$2:$R$15000"), 4, 0)
Cells(rng.Row, "F").Value = Application.VLookup(rng, Sh2.Range("$A$2:$R$15000"), 5, 0)
Cells(rng.Row, "J").Value = Application.VLookup(rng, Sh2.Range("$A$2:$R$15000"), 9, 0)
Cells(rng.Row, "K").Value = Application.VLookup(rng, Sh2.Range("$A$2:$R$15000"), 10, 0)
Cells(rng.Row, "L").Value = Application.VLookup(rng, Sh2.Range("$A$2:$R$15000"), 11, 0)
Cells(rng.Row, "M").Value = Application.VLookup(rng, Sh2.Range("$A$2:$R$15000"), 12, 0)
Cells(rng.Row, "N").Value = Application.VLookup(rng, Sh2.Range("$A$2:$R$15000"), 13, 0)
Cells(rng.Row, "O").Value = Application.VLookup(rng, Sh2.Range("$A$2:$R$15000"), 14, 0)
Cells(rng.Row, "P").Value = Application.VLookup(rng, Sh2.Range("$A$2:$R$15000"), 15, 0)
Cells(rng.Row, "Q").Value = Application.VLookup(rng, Sh2.Range("$A$2:$R$15000"), 16, 0)
Cells(rng.Row, "R").Value = Application.VLookup(rng, Sh2.Range("$A$2:$R$15000"), 17, 0)
Cells(rng.Row, "S").Value = Application.VLookup(rng, Sh2.Range("$A$2:$R$15000"), 18, 0)
Cells(rng.Row, "T").Value = Sh2.Range("G19") 'Essentially I need to repeat this for every cell
Cells(rng.Row, "U").Value = Sh2.Range("H19") 'all the way to - Cells(rng.Row, "DT").Value = Sh2.Range("DG19")
Cells(rng.Row, "V").Value = Sh2.Range("I19") 'is there anyway I can do this with 1 line of code
Cells(rng.Row, "W").Value = Sh2.Range("J19") 'instead of like 100 seperate lines?
Cells(rng.Row, "X").Value = Sh2.Range("K19") 'Not as critical but can it be done with the Vlookup section above
Cells(rng.Row, "Y").Value = Sh2.Range("L19") 'to clean up the code as Row J-S is all in order
Cells(rng.Row, "Z").Value = Sh2.Range("M19")
End If
Next rng
Sh1.Range("A" & Last_Row2).Select
Selection.Autofill Destination:=Sh1.Range("("A" & Last_Row2):("A" & Last_Row)")
'Currently this last line doesnt work
'I need this to be able to autofill "A" from whatever the last Row in "A" is to the last row in "B"
End Sub
Option Explicit ' at the top of each module
Sub ImportData() ' use something more descriptive
' Reference the workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' If it isn't, specify it by name or use 'ActiveWorkbook' instead.
' Reference the source objects (worksheet, ranges).
Dim sws As Worksheet: Set sws = wb.Sheets("Codes")
Dim slrg As Range:
Set slrg = sws.Range("A2", sws.Cells(sws.Rows.Count, "A").End(xlUp))
Dim srg As Range: Set srg = slrg.EntireRow
' Reference the destination objects (worksheet, range).
Dim dws As Worksheet: Set dws = wb.Sheets("Certificates")
Dim drg As Range:
Set drg = dws.Range("B2", dws.Cells(dws.Rows.Count, "B").End(xlUp))
' Autofill formulas in column 'A' for the newly added rows.
With dws.Cells(dws.Rows.Count, "A").End(xlUp)
.Autofill Destination:=.Resize(drg.Cells(drg.Cells.Count).Row - .Row + 1)
End With
' Import data.
Dim dcell As Range, sRow As Variant
For Each dcell In drg.Cells
With dcell.EntireRow
If dcell.Value > 0 And .Columns("E").Value = 0 Then
sRow = Application.Match(dcell.Value, slrg, 0)
If IsNumeric(sRow) Then
.Columns("E:F").Value = srg.Rows(sRow).Columns("D:E").Value
.Columns("J:S").Value = srg.Rows(sRow).Columns("I:R").Value
Else
.Columns("E:F").Value = ""
.Columns("J:S").Value = ""
End If
.Columns("T:DT").Value = sws.Range("G19:DG19").Value
End If
End With
Next dcell
' Inform.
MsgBox "Data imported.", vbInformation
End Sub