Alternative to Vlookup using macros

[Kemidan2014]

I am hoping this wonderful community can help me once again! with one problem of using Copy paste to paste on criteria from one work sheet another has been solved. i found that becuase my SOURCE worksheet for this task is 1000+ rows and 22 columns of Vlookups referencing a master file who will be overwritten as needed based on information we get from customers. This is causing a very long processing time for the newly added copy paste macro to work. i have found that if my Sheet 1 source data is just text it works INSTANTLY.

my solution needs to be my source sheet also needs to be a copy pasted data from our Masterfile instead of Vlookups. and as it wont be as easy as using the same macro.

I want to copy and paste all rows of data from my master file but i want to EXCLUDE certain columns because this information is irrelevent.

Source: Master file has headers in Row 1, 39 Columns and then Data below that about 1000+ rows of it and grows over time
Destination: Current working file "Sheet1" Same headers in Row 1 but only 23 of the columns of information that we want in this sheet

how would i target in VBA to only copy those specified columns and give me all the corresponding information below that column.

heres headers from source file

ToyotaData.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH	AI	AJ	AK	AL	AM
1	QIMS#	Doc Type	Instance Handle Key	Rank	Supplier Code	TMMC Supplier Code	Supplier Name	Part Name	Part Number	Overall Status	NCD Description	QEName	Full Name	Full Name	Model	SQA Rank	LT CM Plan Due	Original LTCM Actual Due Date	Revised LTCM Actual Due Date	Close	Initial Issuance Date	Official Issuance Date	LTCM Plan Submitted	LTCM Plan Accepted Date	LTCM Plan Rejection Date	LTCM Actual Submitted	LTCM Actual Accepted Date	LTCMActualRejectionDate	Occurence	Where NC found?	Will Parts Be Quarantined ?	Why Made Category	Why Shipped Category	NAMC	ST/CM Status	LT/CM Status	Standard	Actual	Assigned To
Data

heres what i want to get to

Customer database test 2.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V
1	QIMS#	Doc Type	Rank	Supplier Code	Part Name	Part Number	Overall Status	NCD Description	Model	LT CM Plan Due	Original LTCM Actual Due Date	Revised LTCM Actual Due Date	Close	Initial Issuance Date	Official Issuance Date	LTCM Plan Submitted	LTCM Plan Accepted Date	LTCM Plan Rejection Date	LTCM Actual Submitted	LTCM Actual Accepted Date	LTCMActualRejectionDate	NAMC
Sheet1

I apologize but due to nature of the info i cant publically share it. just assume there 1000+ rows of data in each cell below up and that will grow over time so lastrow will always be different.

 

[Kemidan2014]

Let me know your thoughts on this code the only issue it on "Set srcWB...." line i get a runtime error that it can not find cells so i am not sure whats wrong with that line

Sub Update_trial()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWB As Workbook, desWB As Workbook
    Workbooks.Open ("O:\1_All Customers\Current Complaints\ToyotaData.xlsx")
    Set srcWB = Workbooks("O:\1_All Customers\Current Complaints\ToyotaData.xlsx").Worksheets("Data")
    Set desWB = Workbooks("Customer Database Test 2.xlsm").Worksheets("sheet1")
    LastRow = srcWB.Cells.Find("Q*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    With srcWB
        .Range("AN2:AN" & LastRow).Formula = "=IF(MATCH(A2,'[Customer database test 2.xlsm]Sheet1'!$A$2),""true"",""false"")"
        .Cells(1).CurrentRegion.AutoFilter 23, "false"
        .Range("A:B,D:D,E:E,H:K,O:O,Q:AB,AH:AH" & LastRow).SpecialCells(xlCellTypeVisible).Copy
        With desWB
            .Cells(.Rows.count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues
            .Columns.AutoFit
        End With
        .Range("A1").AutoFilter
        .Columns("W").Delete
    End With
    Application.ScreenUpdating = True
End Sub

 

[DanteAmor]

It is an excellent example!
So, consider the data in this QIMS# column, to add new records.

In addition to adding the new records. Of the QIMS# that already exist in the destination sheet, you also want to make updates, that is, for example, if for 01-01016-V6-5002 you changed the NCD Description from "LOOSE" to "WRONG PART", then the macro should update sheet1?

 

[Kemidan2014]

Yes that correct! we WOULD want to do that. I totally forgot to consider dates being added as the steps progress through the complaint process which would need to be filled on older complaints so the code i just posted wont work it would just only find new record (if it did work) instead up updating the older ones

 

[DanteAmor]

the code i just posted wont work

However, I made some corrections to the code.

Sub Update_trial()
  Dim lr As Long
  Dim srcSH As Worksheet, desSH As Worksheet
  
  Application.ScreenUpdating = False
  Workbooks.Open ("O:\1_All Customers\Current Complaints\ToyotaData.xlsx")
  Set srcSH = ActiveWorkbook.Sheets("Data")
  Set desSH = Workbooks("Customer Database Test 2.xlsm").Worksheets("sheet1")
  
  With srcSH
    If .AutoFilterMode Then .AutoFilterMode = False
    lr = .Range("A" & Rows.Count).End(3).Row
    .Range("AN2:AN" & lr).Formula = "=IFERROR(IF(MATCH(A2,'[" & desSH.Parent.Name & "]" & desSH.Name & "'!$A:$A,0),""true"",""false""),""false"")"
    .Cells(1).CurrentRegion.AutoFilter 40, "false"
    If srcSH.Range("A" & Rows.Count).End(3).Row > 1 Then
      .Range("A2:B" & lr & ",D2:E" & lr & ",H2:K" & lr & ",O2:O" & lr & ",Q2:AB" & lr & ",AH2:AH" & lr).SpecialCells(xlCellTypeVisible).Copy
      desSH.Cells(.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues
      desSH.Columns.AutoFit
    End If
    .Range("A1").AutoFilter
    .Columns("AN").ClearContents
  End With
  srcSH.Parent.Close False
  Application.ScreenUpdating = True
End Sub

Now, I understood the requirement. I prepare a new code to update data and add new ones.

 

[DanteAmor]

The following macro updates and adds new records.
Let's save the step of opening the file, first open the file and try the macro:

Sub Update_trial_3()
  Dim srcSH As Worksheet, desSH As Worksheet
  Dim i As Long, j As Long, nRow As Long, n As Long
  Dim rng As Range, col As Range, c As Range, f As Range
 
  Set srcSH = Workbooks("ToyotaData.xlsx").Sheets("Data")
  Set desSH = Workbooks("Customer Database Test 2.xlsm").Sheets("sheet1")
  Set rng = srcSH.Range("A:B,D:E,H:K,O:O,Q:AB,AH:AH")
 
  For Each c In srcSH.Range("A2", srcSH.Range("A" & Rows.Count).End(3))
    Set f = desSH.Range("A:A").Find(c.Value, , xlValues, xlWhole, , , False)
    If Not f Is Nothing Then nRow = f.Row Else nRow = desSH.Range("A" & Rows.Count).End(3).Row + 1
    j = 0
    For Each col In rng.Columns
      n = col.Column
      j = j + 1
      desSH.Cells(nRow, j).Value = srcSH.Cells(c.Row, n).Value
    Next
  Next
End Sub

 

[Kemidan2014]

OK i tested both sets of codes. Both generated Run time Error.

1st one you posted failed at PastingSpecial, if opened Toyotadata, filtered to False, (becasue we had an update since i last downloaded so it was a good time to test) Found the new record, copied it. but then it couldnt paste it

"desSH.Cells(.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues" i looked at the destination sheet and you can see Excel had hilighted first blank row as if it was attempting to paste.

The 2nd code generated Run Time error 9 at

Set srcSH = Workbooks("ToyotaData.xlsx").Sheets("Data") i am wondering if this is because the entire drive location isnt filled out?

im going to try the first code again and and change "PasteSpecial xlPasteValues" to "PasteSpecial Paste:=xlPasteValues" becuase this is what ive used before

 

[Kemidan2014]

OK! Step one im an idiot and left sheet protected but added Paste:= works!! and added the new record to the BOTTOM instead of in the MIDDLE where its found in the master sheet.

I tried the 2nd macro again and it still failed to find the source

 

[Kemidan2014]

Adding the corrected code that works for the communities benefit

Sub Update_trial()
  Dim lr As Long
  Dim srcSH As Worksheet, desSH As Worksheet
 
  Application.ScreenUpdating = False
  Workbooks.Open ("O:\1_All Customers\Current Complaints\ToyotaData.xlsx")
  Set srcSH = ActiveWorkbook.Sheets("Data")
  Set desSH = Workbooks("Customer Database Test 2.xlsm").Worksheets("sheet1")
 
  With srcSH
    If .AutoFilterMode Then .AutoFilterMode = False
    lr = .Range("A" & Rows.Count).End(3).Row
    .Range("AN2:AN" & lr).Formula = "=IFERROR(IF(MATCH(A2,'[" & desSH.Parent.Name & "]" & desSH.Name & "'!$A:$A,0),""true"",""false""),""false"")"
    .Cells(1).CurrentRegion.AutoFilter 40, "false"
    If srcSH.Range("A" & Rows.Count).End(3).Row > 1 Then
      .Range("A2:B" & lr & ",D2:E" & lr & ",H2:K" & lr & ",O2:O" & lr & ",Q2:AB" & lr & ",AH2:AH" & lr).SpecialCells(xlCellTypeVisible).Copy
      desSH.Cells(.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
      desSH.Columns.AutoFit
    End If
    .Range("A1").AutoFilter
    .Columns("AN").ClearContents
  End With
  srcSH.Parent.Close False
  Application.ScreenUpdating = True
End Sub

 

[Kemidan2014]

Well i flagged too soon, i did a another test, although the code works without error I edited the master sheet to throw a date in a cenn that was blank to see if it would pick it up and it did not.

 

[DanteAmor]

The following macro updates and adds new records.

The code you should use is that of post #15, as it updates and adds records. Obviously the records are added at the end of the base. If you want, the data can be sorted by ID.
In the destination sheet the data will be pasted in cell A2 onwards, so is your example. If you don't want them in cell A2, then I must modify the macro.