excel vlookup multiple values and workbooks - excel

I know this topic has been asked about before but nothing quite covers what I need. So here's the thing..
I have two workbooks. One is exported from another program which shows a staff member's Surname, first name, email and which ward they work on.
[Workbook1 example]
The second is the full staff list which has the same details but also a check list column.
[Workbook2 example]
What I need is a macro (probably a vlookup) which takes the information from the workbook1, checks against surname, first name and ward on workbook2 to ensure that it is the correct member of staff, copies the email onto workbook 2 and also fills the checklist column on workbook 2 to "Yes".
I'm afraid I am at a loss as to how to incorporate all of this together. Please help.
This is what I have so far but my knowledge is limited and did not know how to proceed.
Private Sub UpdateTraining_Click()
Dim I As Integer
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim Ws3 As Worksheet
Dim Wb As Workbook
Dim CopyData As String
Dim RwCnt As Long
Dim RwCnt2 As Long
Dim Rw As Long
Dim Clm As Long
Dim SName As String
Dim FName As String
Dim Wrd As String
Dim vArr
Dim ClmLet As String
Set Ws1 = Workbooks("Nursing Docs Training Record.xlsm").Worksheets("Staff Training Record")
Set Ws2 = Workbooks("Nursing Docs Training Record.xlsm").Worksheets("Do Not Use")
Workbooks.Open ("C:\TypeformNursingDocumentation.xlsx")
Set Ws3 = Workbooks("TypeformNursingDocumentation.xlsx").Worksheets("tWeXNp")
RwCnt = Ws3.Cells(Rows.Count, 1).End(xlUp).Row
RwCnt2 = Ws1.Cells(Rows.Count, 1).End(xlUp).Row
Rw = Ws3.Range("F2").Row
Clm = Ws3.Range("F2").Column
Table1 = Ws3.Range("F2:F" & RwCnt)
vArr = Split(Cells(1, Clm).Address(True, False), "$")
ClmLet = vArr(0)
For Each cl In Table1
Ws3.Range(ClmLet & Rw).Select
SName = ActiveCell.Value
FName = ActiveCell.Offset(0, -1).Value
Wrd = ActiveCell.Offset(0, -4).Value
Rw = Rw + 1
Next cl
End Sub

You can achieve this with formulas but then you have to open Workbook1 for the formulas to work in Workbook2. So below approach uses VBA to achieve the results
Copy the below UDF in a module in Workbook2:
Sub UpdateMyList()
Dim oSourceWB As Workbook
Dim oSourceR As Variant
Dim iTotSRows&, iTotCRows&, iCC&, iSC&
Dim oCurR As Variant
Application.ScreenUpdating = False
' First lets get source data
Set oSourceWB = Workbooks.Open("C:\Temp\EmpLookup.xlsx", ReadOnly:=True) ' Change the source file name
With oSourceWB.Worksheets("Sheet1") ' Change the source sheet name
iTotSRows = .Range("A" & .Rows.count).End(xlUp).Row
oSourceR = .Range("A2:G" & iTotSRows)
End With
oSourceWB.Close False
' We now need the data from the sheet in this workbook to compare against
With ThisWorkbook.Worksheets("Sheet8") ' Change the sheet name to the sheet in your workbook
iTotCRows = .Range("A" & .Rows.count).End(xlUp).Row
oCurR = .Range("A2:H" & iTotCRows)
End With
' Next, lets compare and update fields
For iCC = 1 To UBound(oCurR)
For iSC = 1 To UBound(oSourceR)
If (oCurR(iCC, 1) = oSourceR(iSC, 6)) And (oCurR(iCC, 2) = oSourceR(iSC, 5)) And (oCurR(iCC, 5) = oSourceR(iSC, 2)) Then
oCurR(iCC, 7) = oSourceR(iSC, 7)
oCurR(iCC, 8) = "Yes"
Exit For
End If
Next
Next
Application.ScreenUpdating = True
' Finally, lets update the sheet
ThisWorkbook.Worksheets("Sheet8").Range("A2:H" & iTotCRows) = oCurR
End Sub
I've commented on the lines where you need to change references to workbook or worksheets. As long as you have updated the workbook and worksheet references, this should give you the desired results
I built the above UDF based on the columns as you provided in your question. If the columns change, you will have to modify the UDF or get the columns dynamically

You can use and If(Countif()) style function, where the countif checks for the presence of your value, and the if will return true if it is a match, then you can use the if true / false values accordingly. Let me know if you need more details but it could look something like this =IF(COUNTIF(The selected cell is in the selected range),"Yes", "No"). Then record this as a macro and copy the code into yours.

Related

Excel Marco - How to combine and name datasets

I am trying to consolidate data from a list of file paths into one worksheet then add the names per dataset. I have a list of names and paths set up like this in Excel:
Name1, Path1
Name2, Path2
Name3, Path3
The macro I have written so far loops through the paths, copy and paste into the master spreadsheet starting in the first empty in column B. What I want the macro to also do is also fill in column A with Name1, Name2, and Name3 next to the respective dataset. I got the macro do to the first part but now I can't get it to do the naming part. Here is my code so far:
Sub Data()
Dim ws As Worksheet, dataws As Worksheet
Dim wkb As Workbook, wkbFrom As Workbook
Dim wkblist As Range
Dim fromtab As String
Dim Name As String
For Each wkblist In Sheets("Ref").Range("d4:d18")
If wkblist.Value = "" Then
Exit For
Else
Set wkb = ThisWorkbook
Set wkbFrom = Workbooks.Open(wkblist)
Set ws = wkb.Sheets("Ref")
Set dataws = wkb.Sheets("Data")
fromtab = ws.Range("b22")
wkbFrom.Worksheets(fromtab).Range("b2:z200").Copy
dataws.Cells(Rows.Count, 5).End(xlUp).Offset(1).PasteSpecial xlValues
Application.CutCopyMode = False
wkbFrom.Close
End If
Next wkblist
End Sub
Ta,
I'm not too sure what worksheet you want the names to be pasted; I assume the data WS in the code below. Also, I would set the wkb, ws, and dataws outside of the loop since they are or belong to "ThisWorkbook". Not that it hurts to be inside of the loop, but you're just resetting them each time the loop runs.
The code below should find the range of rows that you just pasted into dataws. Then, it copies the names that are related to the wkblist in Col C into Col A of dataws.
Dim colARow, colBRow As Long
' Place code below after you paste the paths into Col B of the worksheet
' Find first blank in Col A
colARow = dataws.Cells(Rows.Count, 1).End(xlUp).Row + 1
' Find last filled cell in Col B
colBRow = dataws.Cells(Rows.Count, 2).End(xlUp).Row
dataws.Range("A" & colARow & ":A" & colBRow).Value = wkblist.Offset(0,-1).Value

Sum the same table across different number of worksheets

So i have an excel file where i can enter the different projects that i want to analyse and the location of the files. Then a code to go and get the files and generate 2 sheets (from a template that i created) for each project entered and populate the data. These projects can vary the name and quantity.
My problem appears when i try to do a total table. Where i would go and get from the same cell in the different sheets the value and sum them. The number of sheets can change so i didnt manage to use a sheets.count, but the name of the sheets that relevant for this operation all start by "Total_".
So the beginning of the code that i have so far is:
`Sub refresh()
Parametre
Dim nbOnglet As Integer
Dim nbProjet As Integer
Dim name As String
Dim nametot As String
Dim A As String
Dim B As String
Dim idx As Integer
Dim iDebut As Integer
Dim values As Variant
Dim rng As Range
Dim xRng As Range
Dim x As Long
Dim vArray As Variant
Dim dSum As Double
Initialisation
iDebut = 9
Déterminer le nombre d'onglets du Classeur
nbOnglet = Sheets.Count
Déterminer le nombre de projet à traiter
folderpath = Range("C3").Value
Sheets("Sommaire").Select
nbLigne = Cells(10, "A").Value
x = 0
For idx = 1 To nbLigne
activate Récapitulatif
Sheets("Récapitulatif").Select
Define the variable name - tab name
A = "Total_"
B = Sheets("Sommaire").Cells(iDebut + idx, "D").Value
name = B
nametot = A & B`
Then for the sun i have tried different options but none appears to work for the entire table. I managed to get the good result for one cell by using the following:
x = x + sheets(nametot).range("F7").Value2
But couldn't do it for all the range (F7:CI31).
Other formula that i have tried was:
Set xRng = ThisWorkbook.Sheets(nbLigne).Range("K7:CI31")
xRng.FormulaR1C1 = "=SUM('" & ThisWorkbook.Sheets(nametot).name & "'!RC+'" & ThisWorkbook.Sheets(nametot).name & "'!RC)"
Although this gives the equation that i want since it is running in a loop, it calculates the same for each sheet and stops at the last one identified... So not doing what i would like to: sum the same cell across the different sheets named 'Total_XXXX' and present the value in the 'Récapitulatif' sheet.
I have been looking around internet and i can't really figure out a way to do it.
DO you have any ideas?
Thank you so much in advance
example of the table
Consolidate Worksheets
Links (Microsoft Docs)
Range.Address
Range.Consolidate
XlConsolidationFunction Enumeration
Description
In the workbook containing this code (ThisWorkbook), the following will consolidate (in this case sum up (xlSum)) all the same ranges (srcRange) in all worksheets with names starting with a specified string (srcLead) into another worksheet (tgtName) starting from a specified cell (tgtFirst).
The Code
Option Explicit
Sub consolidateWorksheets()
' Define constants.
Const srcRange As String = "K7:CI31"
Const srcLead As String = "Total_"
Const tgtName As String = "Récapitulatif"
Const tgtFirst As String = "A1"
' Define workbook.
Dim wb As Workbook
Set wb = ThisWorkbook
' Define Target Worksheet.
Dim tgt As Worksheet
Set tgt = wb.Worksheets(tgtName)
' Define R1C1-Style Source Ranges Address.
Dim rcRng As String
rcRng = tgt.Range(srcRange).Address(ReferenceStyle:=xlR1C1)
' Define Consolidation Array.
Dim Data As Variant
ReDim Data(1 To wb.Worksheets.Count)
' Declare variables.
Dim ws As Worksheet ' Current Source Worksheet
Dim CurrentName As String ' Current Source Worksheet Name
Dim n As Long ' Current Element in Consolidation Array
' Write full paths of Source Worksheets to Consolidation Array.
For Each ws In wb.Worksheets
CurrentName = ws.Name
If InStr(1, CurrentName, srcLead, vbTextCompare) = 1 Then
n = n + 1
Data(n) = "'" & ws.Name & "'!" & rcRng
End If
Next ws
' Validate and resize Consolidation Array.
If n = 0 Then
MsgBox "No worksheets to consolidate.", vbCritical, "Fail"
Exit Sub
End If
ReDim Preserve Data(1 To n)
' Consolidate.
tgt.Range(tgtFirst).Consolidate Sources:=Data, _
Function:=xlSum
' Inform user.
MsgBox "Data consolidated.", vbInformation, "Success"
End Sub

If statement for two values for large set of data

I struggle with VBA and have spent a few days trying to find a solution to this problem. Essentially, I have two spreadsheets with large sets of data. Column K of "Design Mods" worksheet contains the same types of values as Column C of the "Output" Worksheet. I've been trying to get my script to do the following:
1. for each cell in column k of "Design Mods", check if there is a matching cell in column c of the "output" spreadsheet
2. if a match is found, then populate the cell in "Design Mods" to columns over with the information from column b of "Output"
Because of my lack of experience, I've only been able to setup the script below which only checks and pulls correctly for one cell.
I need it to check each cell against a range of other cells.
Any help/guidance would be very much appreciated.
Thank you very much!
Sub MatchValue_Test()
'Routine is meant to populate columns "Design Mods" Spreadsheet with affected calculations from the "Output" Spreadsheet
'Variables below refer to Design Mods spreadsheet
Dim designmod As Worksheet '<-- Design Mods worksheet that we are comparing to the Output Data
Dim DesignMod_DClrow As Integer '<-- Variable used to count to the last low in the DC Number Column of Design Mods Spreadsheet
Dim designmoddc As Range '<-- Variable used to identify the range of values being checked in Design Mods is the DC Numbers Column K from K4 to the end of the column
Dim valuetofind As String '<-- DC Number used as matching criteria between Design Mods spreadsheet and Output Data
'Test Variables for integrating references to from Output worksheet
Dim testset As Worksheet
Dim test2_lrow As Integer
Dim test As Range
Dim valuetofindw2 As String
'Variables below pertain the routine itself
Dim found As Boolean '<-- this condition has to be false to start the routine
'Start of Routine
found = False
'Definition of Data Ranges in Design Mods spreadsheet
Set designmod = ActiveWorkbook.Worksheets("Sheet1")
DesignMod_DClrow = designmod.Range("K4").End(xlDown).Row
Set designmoddc = designmod.Range("K4:K" & DesignMod_DClrow)
'Test variables for integrating values from Output worksheet
Set testset = ActiveWorkbook.Worksheets("Sheet2")
test2_lrow = testset.Range("C2").End(xlDown).Row
Set test = testset.Range("C2:C" & test2_lrow)
'Identify the value being matched against
valuetofind = designmod.Range("L4").Value '<-- the script wont run if I have this value set to a range, and I need to figure out get this to loop so I don't need a variable for every cell im checking against
'test variables to figure out if statement
valuetofindw2 = testset.Range("C2").Value
valuetofindw3 = testset.Range("B2").Value
valuetofindw4 = designmod.Range("K4")
'If Statements performing the comparison
For Each Cell In designmoddc
If Cell.Value = valuetofindw3 Then
found = True
End If
Next
If found = True Then
designmoddc.Cells.Offset(0, 2).Value = testset.Range("B2")
End If
End Sub
You did not answer my clarification questions...
I prepared a solution, able to work very fast (using arrays). Please back-up your workbook, because the code will rewrite the matching cases in column M:M.
Sub MatchValue_TestArrays()
Dim designMod As Worksheet, lastRowD As Long, testSet As Worksheet, lastRowT As Long
Dim arrDes As Variant, arrTest As Variant, d As Long, t As Long, boolFound As Boolean
Set designMod = Worksheets("Sheet1")
Set testSet = Worksheets("Sheet2")
lastRowD = designMod.Range("K" & Cells.Rows.Count).End(xlUp).Row
lastRowT = testSet.Range("C" & Cells.Rows.Count).End(xlUp).Row
arrDes = designMod.Range("K4:M" & lastRowD).value 'load the range in array
arrTest = testSet.Range("B2:C" & lastRowT).value
For d = 1 To UBound(arrDes, 1)
For t = 1 To UBound(arrTest, 1)
If arrDes(d, 1) = arrTest(t, 2) Then
arrDes(d, 3) = arrTest(t, 1)'fill the array third column (M:M) with values of B:B testSheet...
Exit For
End If
Next t
Next d
designMod.Range("K4:M" & lastRowD).value = arrDes' Drop the modified array
End Sub
Try the updated code, please. It searches now for all occurrences and put each one in a consecutive column:
Sub MatchValue_TestArrays_Extended()
Dim designMod As Worksheet, lastRowD As Long, testSet As Worksheet, lastRowT As Long
Dim arrDes As Variant, arrTest As Variant, d As Long, t As Long, col As Long
Set designMod = Worksheets("Design") ' Worksheets("Sheet1")
Set testSet = Worksheets("TestS") ' Worksheets("Sheet2")
lastRowD = designMod.Range("K" & Cells.Rows.Count).End(xlUp).Row
lastRowT = testSet.Range("C" & Cells.Rows.Count).End(xlUp).Row
arrDes = designMod.Range("K4:AQ" & lastRowD).value
arrTest = testSet.Range("B2:C" & lastRowT).value
For d = 1 To UBound(arrDes, 1)
col = 3 'the column where the occurrence will be put
For t = 1 To UBound(arrTest, 1)
If arrDes(d, 1) = arrTest(t, 2) Then
arrDes(d, col) = arrTest(t, 1): col = col + 1
End If
Next t
Next d
designMod.Range("K4:AQ" & lastRowD).value = arrDes
End Sub
Using Match() is fast when your data is on a worksheet:
Sub MatchValue_Test()
Dim wsDesign As Worksheet, wsOut As Worksheet, m, c As Range
Set wsDesign = ActiveWorkbook.Worksheets("Sheet1")
Set wsOut = ActiveWorkbook.Worksheets("Sheet2")
For Each c In wsDesign.Range(wsDesign.Range("K4"), _
wsDesign.Cells(Rows.Count, "k").End(xlUp)).Cells
m = Application.Match(c.Value, wsOut.Columns("C"), 0)
If Not IsError(m) Then
'if Match() found a hit then m will be the row number on sheet2
c.Offset(0, 2).Value = wsOut.Cells(m, "B").Value
End If
Next c
End Sub

How to copy specific data from one worksheet to another using VBA

I need help editing my code so that it does something more specific. Currently the code separates all data from a "Data" worksheet in to separate corresponding worksheets using the "Name of Opportunity" column. I need it so that it separates depending on what the user wants it to separate by. So for example, in field W11 on a separate worksheet called "Diagram" the user can enter "Co" as a opportunity and when they click the "Split Data" button on the same worksheet it should only split by "Co" and put it in a separate worksheet called "Opportunity"
Here is the scenario I am trying to achieve:
User enters an opportunity name in the “Diagram” worksheet in field W11
User presses “Split Data” button in “Diagram” worksheet
A separate worksheet is automatically created called “Opportunity”
Looks-up the “Name of Opportunity” column in the “Data” worksheet and compares it with the user entry (step 1)
All the data that corresponds with the users entered field (step 1) will be copied over into the newly made “Opportunity” worksheet – This includes the entire row (all 4columns A-D of that specific entry).
Example: If a user types in "Co" in the W11 field and then presses the "Split Data" - all the "Co" opportunities will be put in a separate worksheet (called "Opportunity")
Data Worksheet
Diagram Worksheet
Assumptions:
The user can press the “Split Data” button again and it should re-do the process (Overwrite the “Opportunity” worksheet)
As the data on the "Data" worksheet will be always increasing the range that it looks up should be end of row
What I have done
As stated above I am struggling to get the code to be more specific (unsure how to go about editing the code - can't find anything online that helps me understand). I am currently able to split all data into different worksheets but I need it only to be split by what the user wants. Here is the code I have below:
Private Sub CommandButton2_Click()
Const col = "A"
Const header_row = 1
Const starting_row = 2
Dim source_sheet As Worksheet
Dim destination_sheet As Worksheet
Dim source_row As Long
Dim last_row As Long
Dim destination_row As Long
Dim Opp As String
Set source_sheet = Workbooks("CobhamMappingTool").Worksheets("Data")
last_row = source_sheet.Cells(source_sheet.Rows.Count, col).End(xlUp).Row
For source_row = starting_row To last_row
Opp = source_sheet.Cells(source_row, col).Value
Set destination_sheet = Nothing
On Error Resume Next
Set destination_sheet = Worksheets(Opp)
On Error GoTo 0
If destination_sheet Is Nothing Then
Set destination_sheet=Worksheets.Add(after:=Worksheets(Worksheets.Count))
destination_sheet.Name = Opp
source_sheet.Rows(header_row).Copy Destination:=destination_sheet.Rows(header_row)
End If
destination_row = destination_sheet.Cells(destination_sheet.Rows.Count, col).End(xlUp).Row + 1
source_sheet.Rows(source_row).Copy Destination:=destination_sheet.Rows(destination_row)
Next source_row
End Sub
Any help is appreciated
Many thanks,
James
If you already have a worksheet "Opportunity", the code below will clear that worksheet, then use the value from W11 on the Diagram worksheet to filter Column A of the Data worksheet and copy the range in one go, instead of row by row:
Private Sub CommandButton2_Click()
Dim wsSource As Worksheet: Set wsSource = Workbooks("CobhamMappingTool").Worksheets("Data")
Dim wsDiagram As Worksheet: Set wsDiagram = ThisWorkbook.Worksheets("Diagram")
Dim wsDestination As Worksheet: Set wsDestination = ThisWorkbook.Worksheets("Opportunity")
'declare and set worksheets
Dim LastRow As Long
Dim FoundVal As Variant
wsDestination.Cells.ClearContents
'clear the contents of workhsheet "Opportunity"
LastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
'get the last row with data on the data worksheet
Set FoundVal = wsSource.Range("A:A").Find(What:=wsDiagram.Range("W11"), Lookat:=xlWhole)
'check if value exists in Column A
If Not FoundVal Is Nothing Then
'if it does exist, then
wsSource.Range("$A$1:$D$" & LastRow).AutoFilter Field:=1, Criteria1:=wsDiagram.Range("W11")
'filter column A with the desired value
wsSource.Range("A1:D" & LastRow).Copy Destination:=wsDestination.Range("A1")
'copy the range into the Opportunity worksheet.
wsSource.Range("$A$1:$D$" & LastRow).AutoFilter
'remove autofilter
End If
End Sub
There are more than one ways to achieve what you are looking for. The one which uses most of your code is shared below. Notice the new lines that I have added.
Private Sub CommandButton2_Click()
Const col = "A"
Const header_row = 1
Const starting_row = 2
Dim source_sheet As Worksheet
Dim destination_sheet As Worksheet
Dim source_row As Long
Dim last_row As Long
Dim destination_row As Long
Dim Opp As String
Dim oppVal As String
Set source_sheet = ThisWorkbook.Worksheets("Sheet3")
last_row = source_sheet.Cells(source_sheet.Rows.Count, col).End(xlUp).Row
oppVal = Sheets("Diagram").Range("W11").Value
For source_row = starting_row To last_row
Opp = "Opportunity"
'source_sheet.Cells(source_row, col).Value
Set destination_sheet = Nothing
On Error Resume Next
Set destination_sheet = Worksheets(Opp)
On Error GoTo 0
If destination_sheet Is Nothing Then
Set destination_sheet = Worksheets.Add(after:=Worksheets(Worksheets.Count))
destination_sheet.Name = Opp
source_sheet.Rows(header_row).Copy Destination:=destination_sheet.Rows(header_row)
End If
destination_row = destination_sheet.Cells(destination_sheet.Rows.Count, col).End(xlUp).Row + 1
If source_sheet.Range("A" & source_row).Value = oppVal Then
source_sheet.Rows(source_row).Copy Destination:=destination_sheet.Rows(destination_row)
End If
Next source_row
End Sub
You would notice that:
1. the user specified value is being read in oppVal variable.
2. the destination sheet name is always "Opportunity"
3. the code checks if the value in column A is equal to oppVal and then copies it over to destination sheet.
The code gets the job done, however, some enhancements you may do:
1. Clear the data in destination sheet before each run
2. use filters to select the rows instead of loop and then copy-paste the selected rows.

Excel VBA - Copy cells based on criteria to another workbook saved in the same folder

I'm pretty new at this and I've gone through a ton of bundle of tutorials but I can't seem to grasp the concept of how to achieve this result in excel VBA. I'll try being as detailed as possible.
I have a folder with 3 x Excel files -
Script.xlsx (Just a button that holds the script/macro)
WhiteCrown.xlsx (the workbook I'd like to copy the data from)
PackCon.xlsx (the workbook I'd like the data pasted into)
Concept:
If Workbook ("WhiteCrown.xlsx") contains value in Column B5:B10000 which = Workbook ("PackCon.xlsx") Column B5:B10000 AND Workbook ("WhiteCrown.xlsx") contains a value in Column E
There are 2 cells I don't want the value of E copied - "soy-milk" "Pepsi-max"
The check is to be looped till column b
Reaches 10000
:) thanks in advance
Sub ConvertData()
Dim i As Integer, n As Integer
Dim Desc As Range, ExDesc As Range
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rngLookup As Range
Dim v
Application.ScreenUpdating = False
Set wb1 = Workbooks.Open("C:\Users\amir.abdul\Desktop\Completed\New folder\WhiteCrown.xlsx")
Set ws1 = wb1.Sheets("BOMQ")
Set wb2 = Workbooks.Open("C:\Users\amir.abdul\Desktop\Completed\New folder\PackCon.xlsx")
With wb2.Sheets("("BOMQ")")
Set rngLookup = .Range(.Cells(7, 2), _
.Cells(7, 2).End(xlDown)).Resize(, 3)
End With
With ws1
i = 7
Do Until .Cells(i, 2) = ""
v = Application.VLookup(.Cells(i, 2).Value, rngLookup, 3, False)
If Not IsError(v) Then .Cells(i, 4).Value = v
i = i + 1
Loop
End With
wb2.Close False
End Sub
*Script updated but still not working
I do not Understand what data you would like to copy. I have exhibited the logic to do so. Tested and working.
Option Explicit
Private Sub btnScript_Click()
Dim WhiteCrown As Workbook, PackCon As Workbook, DestWorkbook As Workbook
Dim SheetWhiteCrown As Worksheet, SheetPack As Worksheet
Dim RowIndex As Long
Dim RngWhite As Range
Dim RngWhiteCount As Long
Dim ValBWhite, ValBPack, ValEWhite As String
Application.ScreenUpdating = False
Set WhiteCrown = Workbooks.Open("C:\Users\Mani\Desktop\Stackoverflow\WhiteCrown.xlsx")
Set SheetWhiteCrown = WhiteCrown.Sheets("BOMQ")
Set RngWhite = SheetWhiteCrown.Range("RngWhiteData")
RngWhiteCount = SheetWhiteCrown.Range("RngWhiteData").Rows.Count + 5
Set PackCon = Workbooks.Open("C:\Users\Mani\Desktop\Stackoverflow\PackCon.xlsx")
Set SheetPack = PackCon.Sheets("BOMQ")
Set DestWorkbook = Workbooks.Open("C:\Users\Mani\Desktop\Stackoverflow\Script.xlsx")
For RowIndex = 5 To RngWhiteCount
ValBWhite = SheetWhiteCrown.Cells(RowIndex, "B").Value
ValBPack = SheetPack.Cells(RowIndex, "B").Value
ValEWhite = SheetWhiteCrown.Cells(RowIndex, "E").Value
If Not ValBWhite = "" And ValBWhite = "" Then
If Not ((ValEWhite = "SoyMilk") Or (ValEWhite = "Pepsi")) Then
'Perform your copy to Destworkbook or vlookup or anything
Else
'Do Nothing
End If
End If
Next RowIndex
WhiteCrown.Close
PackCon.Close
DestWorkbook.Close False
End Sub
Never use hardocode ranges like Range("B10:E60"). Best coding practise involved using named ranges as in the above code(example "RngWhiteData" is named range). Add error validations.
If you're satisfied please vote this answer.
Regards,
Mani

Resources