I have 3 sheets: DATA, BUILD and RESULT.
DATA - contains all data
BUILD - 1 row that is iterated through VBA procedure (below) and a command button.
RESULT - where I need to put every iterated row of BUILD table.
The following part of the code is expected to add new row to a RESULTS table.
In a RESULTS sheet, rows are copied sometimes in row 2567, sometimes in 237 etc.
I can't understand the logic how VBA determines the row it puts copied rows.
Sheets("RESULTS").Range("A2" & i + 1).Value = Sheets("BUILD").Range("D4").Value 'League Name
Sheets("RESULTS").Range("B2" & i + 1).Value = Sheets("BUILD").Range("E4").Value 'Home Team
Sheets("RESULTS").Range("C2" & i + 1).Value = Sheets("BUILD").Range("F4").Value 'Away Team
This is the full code:
Sub btn_NextMatch()
Application.ScreenUpdating = False
Application.Volatile
Dim Last_row As Double
Dim Last_Col As Integer
Dim i As Integer
Dim sheet As String
sheet = ActiveSheet.Name
Sheets("BUILD").Select
i = Range("A1").Value
Sheets("DATA").Select
Last_row = Range("A" & Rows.Count).End(xlUp).Row
Last_Col = ActiveSheet.Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, LookIn:=xlValues).Column
Last_colletter = Split(Cells(1, Last_Col).Address, "$")(1)
If i = Last_row Then
i = 1
End If
Sheets("BUILD").Range("C2").Value = Sheets("DATA").Range("C" & i + 1).Value 'MatchID
Sheets("BUILD").Range("D4").Value = Sheets("DATA").Range("D" & i + 1).Value 'League Name
Sheets("BUILD").Range("E4").Value = Sheets("DATA").Range("F" & i + 1).Value 'Home Team
Sheets("BUILD").Range("F4").Value = Sheets("DATA").Range("G" & i + 1).Value 'Away Team
Sheets("BUILD").Select
If i = Last_row Then
Range("A1").Value = 1
Else
Range("A1").Value = i + 1
Sheets("RESULTS").Range("A2" & i + 1).Value = Sheets("BUILD").Range("D4").Value 'League Name
Sheets("RESULTS").Range("B2" & i + 1).Value = Sheets("BUILD").Range("E4").Value 'Home Team
Sheets("RESULTS").Range("C2" & i + 1).Value = Sheets("BUILD").Range("F4").Value 'Away Team
End If
Application.ScreenUpdating = True
Sheets(sheet).Select
End Sub
I do not recommend using offset to counter the previous problem. Here are a few items corrected in the code:
Declare last row, column, etc as Long. There are over 1 million rows in Excel and integer will only handle up to 32,767. After that you will overload the value.
Shorten the workbook names by setting them as variables. No need to Dim as string.
Avoid Select and Activate by qualifying your worksheets and variables. That means giving as full information as needed to specify the location ThisWorkbook.Worksheets("Sheet1").Range("A1") versus Range("A1") that could be any sheet. Not only will this ensure proper locations, but will speed up your code by avoiding changing sheets.
Sub btn_NextMatch()
Application.ScreenUpdating = False
Application.Volatile
Dim Last_row As Long
Dim Last_Col As Long
Dim i As Long
Dim wks1 As Worksheet
Dim wks2 As Worksheet
Dim wks3 As Worksheet
Set wks1 = ThisWorkbook.Worksheets("BUILD")
Set wks2 = ThisWorkbook.Worksheets("DATA")
Set wks3 = ThisWorkbook.Worksheets("RESULTS")
i = wks1.Range("A1").Value
Last_row = wks2.Range("A" & Rows.Count).End(xlUp).Row
Last_Col = wks2.Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, LookIn:=xlValues).Column
Last_colletter = Split(wks2.Cells(1, Last_Col).Address, "$")(1)
If i = Last_row Then
i = 1
End If
wks1.Range("C2").Value = wks2.Range("C" & i + 1).Value 'MatchID
wks1.Range("D4").Value = wks2.Range("D" & i + 1).Value 'League Name
wks1.Range("E4").Value = wks2.Range("F" & i + 1).Value 'Home Team
wks1.Range("F4").Value = wks2.Range("G" & i + 1).Value 'Away Team
If i = Last_row Then
wks1.Range("A1").Value = 1
Else
wks1.Range("A1").Value = i + 1
wks3.Range("A" & i + 1).Value = wks1.Range("D4").Value 'League Name
wks3.Range("B" & i + 1).Value = wks1.Range("E4").Value 'Home Team
wks3.Range("C" & i + 1).Value = wks1.Range("F4").Value 'Away Team
End If
Application.ScreenUpdating = True
End sub
Darrel H. is right. If you are concatenating the iteration you're on to the cell address you are doing equivalent of: "A2" & 25 becomes A225, where you really wanted to have "A27". A way around this is to use the offset function. Your code rewritten would be like this:
Sheets("RESULTS").Range("A2" & i + 1).offset(rowoffset:=i + 1).value = Sheets("BUILD").Range("D4").Value 'League Name'
Related
I am trying to do a vlookup using vba to look up each country per continent and return a true value on each column. For example, I get a true under Europe Lookup if Belgium is listed as one of the countries. See below for the current code I have. Issues I want to fix are:
First, I want to be able to lookup each country to confirm if they are in the countries tab. That way, I know if there is a new country I need to add. What I have currently looks up to check if at least one of the countries is listed but would like to make sure all countries are listed.
Additionally, I want to make it automated such that if a new country is added to the countries list, I don't have to edit the macros.
Also, is there a way to do the lookup for separate continents one at a time? Currently, it just returns a true if the country is in the list irrespective of the continents. I know this means I'll have separate lines of codes for each continent but that's fine.
Sub Macro1()
Sheets("Sales Table").Select
Range("D2").Select
Dim LastRowColumnD As Long
LastRowColumnD = Cells(Rows.Count, 1).End(xlUp).Row
Range("D2:D" & LastRowColumnD).Formula = "=SUMPRODUCT(--ISNUMBER(SEARCH('Countries'!R2C1:R11C1,RC[-2])))>0"
Range("E2").Select
Dim LastRowColumnE As Long
LastRowColumnE = Cells(Rows.Count, 1).End(xlUp).Row
Range("E2:E" & LastRowColumnE).Formula = "=SUMPRODUCT(--ISNUMBER(SEARCH('Countries'!R2C1:R11C1,RC[-3])))>0"
End Sub
Not sure what kind of output are you trying to get, but something like this may work for you and you'll need to adapt a little:
Sub test()
Dim i As Long, j As Long, k As Long
Dim LR As Long
Dim Mydata As Variant
Dim WKData As Worksheet
Dim rngCountries As Range
Dim MyF As WorksheetFunction
Set MyF = WorksheetFunction
With ThisWorkbook.Worksheets("Countries")
LR = .Range("B" & .Rows.Count).End(xlUp).Row
Set rngCountries = .Range("A2:B" & LR)
End With
Set WKData = ThisWorkbook.Worksheets("Sales Table")
With WKData
LR = .Range("B" & .Rows.Count).End(xlUp).Row
Mydata = .Range("B2:B" & LR).Value
For i = 1 To UBound(Mydata) Step 1
j = UBound(Split(Mydata(i, 1), ", "))
'j = how many countries -1, so j+1= total countries in cell
For k = 0 To j Step 1
'we loop trough each country in cell
If MyF.CountIfs(rngCountries.Columns(1), Split(Mydata(i, 1), ", ")(k), rngCountries.Columns(2), "Europe") <> 0 Then .Range("E" & (i + 1)).Value = .Range("E" & (i + 1)).Value + 1 'Europe Check
If MyF.CountIfs(rngCountries.Columns(1), Split(Mydata(i, 1), ", ")(k), rngCountries.Columns(2), "Africa") <> 0 Then .Range("F" & (i + 1)).Value = .Range("F" & (i + 1)).Value + 1 'Africa Check
If MyF.CountIfs(rngCountries.Columns(1), Split(Mydata(i, 1), ", ")(k), rngCountries.Columns(2), "Asia") <> 0 Then .Range("G" & (i + 1)).Value = .Range("G" & (i + 1)).Value + 1 'Asia Check
Next k
'check all countries: if the sum equals k+1, then all countries in cell are present
.Range("D" & (i + 1)).Value = IIf(MyF.Sum(Range("E" & (i + 1) & ":G" & (i + 1))) = k, "YES", "NO")
Next i
End With
'clean variables
Erase Mydata
Set MyF = Nothing
Set rngCountries = Nothing
Set WKData = Nothing
End Sub
I've used arrays and Splits to create arrays so you can loop trough each individual country:
Notice I added "Portugal" to check the "NO" value in the "All countries" column. Every NO means there is a country in that cell that is not present in your range of countries.
The CurrentRegion property of Range will catch countries added to the Countries tab.
You don't necessarily need a separate line of code for each continent. If you keep a consistent column naming strategy, you can make the code flexible enough to catch added continents.
Sub macroSplitter()
Dim wb As Workbook
Dim salesSheet As Worksheet, Countries As Worksheet, continent As String
Dim j As Long
Set wb = ThisWorkbook
Set salesSheet = wb.Worksheets("Sales Table")
Set Countries = wb.Worksheets("Countries")
'Range.CurrentRegion selects a region contiguous with the designated cell
countryArray = Countries.Range("A2").CurrentRegion.Value2
For Each cell In salesSheet.Range("B2", salesSheet.Range("B2").End(xlDown))
splitCell = Split(cell, ", ")
For Each country In splitCell
If inCountry(country, countryArray) Then
continent = whichcontinent(country, countryArray)
'using match to look for continent column, and End(xlToRight) to allow for additional continents to be added
Cells(cell.Row, WorksheetFunction.Match(continent & " Lookup", salesSheet.Range("A1", salesSheet.Range("A1").End(xlToRight)), 0)).Value2 = True
Else
cell.Offset(0, 2).Value2 = False
End If
Next
If cell.Offset(0, 2).Value2 = vbNullString Then cell.Offset(0, 2).Value2 = True
For j = WorksheetFunction.Match("Europe Lookup", salesSheet.Range("A1", salesSheet.Range("A1").End(xlToRight)), 0) To salesSheet.Range("A1").End(xlToRight).Column
If Cells(cell.Row, j).Value2 = vbNullString Then Cells(cell.Row, j).Value2 = False
Next
Next cell
End Sub
Private Function inCountry(c, arr) As Boolean
Dim i As Long
For i = 2 To UBound(arr, 1)
If c = arr(i, 1) Then inCountry = True
Next
End Function
Private Function whichcontinent(c, arr) As String
Dim i As Long
For i = 2 To UBound(arr, 1)
If c = arr(i, 1) Then whichcontinent = arr(i, 2)
Next
End Function
I'm writing a macro to concatenate a few columns into another column for a sheet that will eventually have thousands of rows. For the sake of testing I'm using four rows of data. My issue is that the Cells(i,25).Value is not populating when I run the following code. The code isn't breaking and I'm not getting any error messages. I tried assigning a 2 to column 26 using Cells(i,26) and that wasn't working either.
Sub concat()
Dim i As Long
Dim add As String
i = 1
Do Until IsEmpty(Cells(i, 1))
add = Cells(i, 14).Value
Cells(i, 25).Value = Cells(i, 1).Value & " " & Cells(i, 2).Value & " " & Left(add, 3)
i = i + 1
Loop
End Sub
Any help or recommendations would be greatly appreciated!
I recommend you change the code a little. I have used the IsEmpty command before and it's not the most suitable one for this.
Sub concat()
Dim i As Long
Dim add As String
Dim last_1 As Long
Dim last_2 As Long
Dim last_14 As Long
Dim lastCell As Long
last_1 = Sheets("test3").Cells(Rows.Count, 1).End(xlUp).Row
last_2 = Sheets("test3").Cells(Rows.Count, 2).End(xlUp).Row
last_14 = Sheets("test3").Cells(Rows.Count, 14).End(xlUp).Row
lastCell = WorksheetFunction.Max(last_1 , last_2, last_14)
For i = 1 To lastCell
add = Sheets("test3").Cells(i, 14).Value
Sheets("test3").Cells(i, 25).Value = Sheets("test3").Cells(i, 1).Value & " " & Sheets("test3").Cells(i, 2).Value & " " & Left(add, 3)
Next i
End Sub
Beforehand, be aware that I just began using VBA, and I have few coding experience prior to it.
I have two sheets:
public
contacts
There is one parameter on column A that is definitely on "contacts" sheet, but may be or not be on column A on "public" sheet.
What I'm doing is:
Checking if the parameter contacts.A2 is on public.A2.
If it is, I need to copy columns, on the exact order:
public: A, C, G.
contacts: E, F.
I've found the following code online, and I'm running some adaptations to it, but I'm stuck.
Sub match()
Dim I, total, frow As Integer
Dim found As Range
total = Sheets("public").Range("A" & Rows.Count).End(xlUp).Row
'MsgBox (total) '(verifica se a contagem está ok)
For I = 2 To total
pesquisa = Worksheets("public").Range("A" & I).Value
Set found = Sheets("contacts").Columns("A:A").Find(what:=pesquisa) 'finds a match
If found Is Nothing Then
Worksheets("result").Range("W" & I).Value = "NO MATCH"
Else
frow = Sheets("contacts").Columns("A:A").Find(what:=pesquisa).Row
Worksheets("result").Range("A" & I).Value = Worksheets("public").Range("A" & frow).Value
Worksheets("result").Range("B" & I).Value = Worksheets("public").Range("C" & frow).Value
Worksheets("result").Range("C" & I).Value = Worksheets("public").Range("G" & frow).Value
Worksheets("result").Range("D" & I).Value = Worksheets("contacts").Range("F" & frow).Value
Worksheets("result").Range("E" & I).Value = Worksheets("contacts").Range("G" & frow).Value
End If
Next I
End Sub
What I expect:
to the code do ignore the line 1, as those are headers;
to eliminate de IF above, since I don't need the "NO MATCH"
to the resulting list to be ordered on ascending order, based on the A column.
Can you help me?
edited to include samples of the data and expected results:
I believe I can simplify my needs with the images above. I want to check a client on the public sheet, grab the manager contacts (emails) from the contacts sheet, and create a list that contains branch, manager, and both e-mails on the results sheet.
Creating those images, I realized I have forgotten to account for the second parameter (manager), as there can be multiple managers on a branch. So this is another parameter to account for.
`Public sheet (image)
Contacts sheet(image)
Result sheet(image)
spreadsheet
`
As per my comments, and your updated question with sample, I do believe that your current results do not match that what you say is required; which is looking for both parameters "Branch" and "Manager". Neither does your expected result look like the columns you wanted to extract according to your question. However, going by your sample data and expected output I tried the following:
Sub BuildList()
'Define your variables
Dim x As Long, y As Long
Dim arr1 As Variant, arr2 As Variant
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
'Fill 1st array variable from sheet Contacts
With Sheet1 'Change accordingly
x = .Cells(.Rows.Count, 1).End(xlUp).Row
arr1 = .Range("A2:D" & x).Value
End With
'Fill dictionary with first array
For x = LBound(arr1) To UBound(arr1)
dict.Add arr1(x, 1) & "|" & arr1(x, 2), arr1(x, 3) & "|" & arr1(x, 4)
Next x
'Fill 2nd array variable from sheet Public
With Sheet2 'Change accordingly
x = .Cells(.Rows.Count, 1).End(xlUp).Row
arr2 = .Range("A2:B" & x).Value
End With
'Compare array against dictionary and fill sheet Results
With Sheet3 'Change accordingly
y = 2
For x = LBound(arr2) To UBound(arr2)
If dict.Exists(arr2(x, 1) & "|" & arr2(x, 2)) Then
.Cells(y, 1).Value = arr2(x, 1)
.Cells(y, 2).Value = arr2(x, 2)
.Cells(y, 3).Value = Split(dict(arr2(x, 1) & "|" & arr2(x, 2)), "|")(0)
.Cells(y, 4).Value = Split(dict(arr2(x, 1) & "|" & arr2(x, 2)), "|")(1)
y = y + 1
End If
Next x
End With
End Sub
This solution makes use of arrays and dictionary which should be fast. It has given me the following result:
As David suggested, it would be better to have an input and output sample. Maybe you can try this:
Option Explicit
Public Sub match()
Dim wsPub As Worksheet
Dim wsCon As Worksheet
Dim wsRes As Worksheet
Dim pubRow As Long
Dim conRow As Long
Dim resRow As Long
Dim i As Long
Dim rng As Range
Dim cel As Range
Dim found As Long
Dim order(1 To 5) As Integer
Set wsPub = ThisWorkbook.Worksheets("public")
Set wsCon = ThisWorkbook.Worksheets("contacts")
Set wsRes = ThisWorkbook.Worksheets("result")
pubRow = wsPub.Cells(wsPub.Rows.Count, 1).End(xlUp).Row
conRow = wsCon.Cells(wsPub.Rows.Count, 1).End(xlUp).Row
resRow = wsRes.Cells(wsRes.Rows.Count, 1).End(xlUp).Row
Set rng = wsPub.Range("A2:A" & pubRow)
order(1) = 1
order(2) = 3
order(3) = 7
order(4) = 6
order(5) = 7
For Each cel In rng
If Not IsError(Application.match(cel.Value, wsCon.Range("A2:A" & conRow), 0)) Then
found = Application.match(cel.Value, wsCon.Range("A2:A" & conRow), 0) + 1
resRow = wsRes.Cells(wsRes.Rows.Count, 1).End(xlUp).Row
For i = 1 To 5
If i < 4 Then
wsRes.Cells(resRow, i).Offset(1, 0).Value _
= cel.Offset(0, order(i) - 1).Value
Else
wsRes.Cells(resRow, i).Offset(1, 0).Value _
= wsCon.Cells(found, order(i)).Value
End If
Next
End If
Next
wsRes.Range("A1").AutoFilter
wsRes.AutoFilter.Sort.SortFields.Clear
wsRes.AutoFilter.Sort.SortFields.Add2 Key:= _
Range("A1:A" & resRow), SortOn:=xlSortOnValues, order:=xlAscending, DataOption:= _
xlSortNormal
wsRes.AutoFilter.Sort.Apply
End Sub
I have a VBA/Formula logic issue which I hope to pick your brains on.
Step 1
User completes a data table from Column C Row 2 onward which tells a macro how many times to duplicate the row by per Column B Row 2.
I have a formula which then populates Column A Row 2 with the column header:
=IF(COUNTA($B2:$D2)=0,"",INDEX($B$1:$G$1,MATCH(FALSE,INDEX(ISBLANK($B2:$G2),0),0)))
The above formula will only populate the first column Name which is great if we are not duplicating the rows. However, the issue is that I need to populate the column header of the row that has been duplicated so it looks at the column after the first one of that row.
Step 2
This is what the finished data table should look like:
Example
Any advice would be appreciated.
Option Explicit
Const TitleRow As Integer = 1
Const StartGenColumn As Integer = 47 ' AU
Sub GenerateRows()
Dim SrcRow As Integer, DestRow As Integer, SrcCol As Integer
Dim NumCoreColumns As Integer, LastGenColumn As Integer
Dim SrcWS As Worksheet, DestWS As Worksheet
Dim i As Integer
NumCoreColumns = StartGenColumn - 1
' find the last column
LastGenColumn = ActiveSheet.Cells(TitleRow, ActiveSheet.Columns.Count).End(xlToLeft).Column
' check if it has the totals
If InStr(ActiveSheet.Cells(TitleRow + 1, LastGenColumn).Formula, "SUM") Then
LastGenColumn = LastGenColumn - 1
Else
' put in a total so that we can tell when we've finished processing
ActiveSheet.Cells(TitleRow + 1, LastGenColumn + 1).Formula = "=SUM(" & ColLetter(StartGenColumn) & (TitleRow + 1) & _
":" & ColLetter(LastGenColumn) & (TitleRow + 1) & ")"
' fill down
ActiveSheet.Range(Cells(TitleRow + 1, LastGenColumn + 1), Cells(ActiveSheet.Rows.Count, LastGenColumn + 1)).FillDown
End If
Set SrcWS = ActiveSheet
If LastGenColumn > StartGenColumn Then
' create the new worksheet
Worksheets.Add
Set DestWS = ActiveSheet
Application.ScreenUpdating = False
' populate the titles
SrcWS.Range(SrcWS.Cells(TitleRow, 1), SrcWS.Cells(TitleRow, NumCoreColumns)).Copy
' always at top of new sheet
DestWS.Range(DestWS.Cells(1, 1), DestWS.Cells(1, NumCoreColumns)).PasteSpecial xlPasteAll
SrcRow = TitleRow + 1
DestRow = 2
' while we still have something to do
Do While SrcWS.Cells(SrcRow, LastGenColumn + 1) <> "" And SrcWS.Cells(SrcRow, LastGenColumn + 1) > 0
' copy the core data
SrcWS.Range(SrcWS.Cells(SrcRow, 1), SrcWS.Cells(SrcRow, NumCoreColumns)).Copy
' what to we need to generate
For SrcCol = StartGenColumn To LastGenColumn
For i = 1 To SrcWS.Cells(SrcRow, SrcCol).Value
DestWS.Range(DestWS.Cells(DestRow, 1), DestWS.Cells(DestRow, NumCoreColumns)).PasteSpecial xlPasteAll
' copy in the title and colour
DestWS.Cells(DestRow, 1).Value = SrcWS.Cells(TitleRow, SrcCol).Value
DestWS.Cells(DestRow, 1).Interior.Color = SrcWS.Cells(TitleRow, SrcCol).Interior.Color
DestRow = DestRow + 1
Next i
Next SrcCol
SrcRow = SrcRow + 1
Loop
Application.CutCopyMode = False
DestWS.Cells(1, 1).EntireColumn.AutoFit
Application.ScreenUpdating = True
End If
End Sub
Private Function ColLetter(Col As Integer) As String
Dim Arr
Arr = Split(Cells(1, Col).Address(True, False), "$")
ColLetter = Arr(0)
End Function
I'm trying to create a macro which copies rows of data after comparing a column value. I previously asked this question but made some progress, and thought it would be less confusing if i posted another question. The column to be compared is "eRequest ID" and it consists of integers and text.
I have two worksheets, both with "eRequest ID" as the first column. The goal here is to copy ANY rows of data that has an "eRequest ID" NOT FOUND in both worksheets. Meaning if this record's "eRequest ID" is only found on one worksheet and not both, the whole row of data has to be copied into a third new worksheet.
I have worked out some codes after browsing through the net, and with the help of the coding experts here. The problem with this codes is that somehow I get a "mismatch" for every row. I tried changing the foundTrue value here and there but it doesn't seem to work. I need it to only copy rows of data with only 1 "eRequest ID" on either worksheet. Greatful for any help and appreciate your effort!
Sub compareAndCopy()
Dim lastRowE As Integer
Dim lastRowF As Integer
Dim lastRowM As Integer
Dim foundTrue As Boolean
Application.ScreenUpdating = False
lastRowE = Sheets("JULY15Release_Master Inventory").Cells(Sheets("JULY15Release_Master Inventory").Rows.Count, "A").End(xlUp).Row
lastRowF = Sheets("JULY15Release_Dev status").Cells(Sheets("JULY15Release_Dev status").Rows.Count, "A").End(xlUp).Row
lastRowM = Sheets("Mismatch").Cells(Sheets("Mismatch").Rows.Count, "A").End(xlUp).Row
For i = 1 To lastRowE
foundTrue = True
For j = 1 To lastRowF
'If Sheets("JULY15Release_Master Inventory").Cells(i, 2).Value = Sheets("JULY15Release_Dev status").Cells(j, 7).Value Then
If Sheets("JULY15Release_Master Inventory").Cells(i, 2).Value <> Sheets("JULY15Release_Dev status").Cells(j, 7).Value Then
foundTrue = False
Exit For
End If
Next j
If foundTrue Then
Sheets("JULY15Release_Dev status").Rows(i).Copy Destination:= _
Sheets("Mismatch").Rows(lastRowM + 1)
lastRowM = lastRowM + 1
End If
Next i
Application.ScreenUpdating = False
End Sub
another one variant
Sub test()
Dim lastRowE&, lastRowF&, lastRowM&, Key As Variant
Dim Cle As Range, Clf As Range
Dim DicInv As Object: Set DicInv = CreateObject("Scripting.Dictionary")
Dim DicDev As Object: Set DicDev = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = 0
lastRowE = Sheets("JULY15Release_Master Inventory").Cells(Rows.Count, "A").End(xlUp).Row
lastRowF = Sheets("JULY15Release_Dev status").Cells(Rows.Count, "A").End(xlUp).Row
lastRowM = Sheets("Mismatch").Cells(Rows.Count, "A").End(xlUp).Row
'add into dictionary row number from Inventory where cell is matched
For Each Cle In Sheets("JULY15Release_Master Inventory").Range("A1:A" & lastRowE)
If Cle.Value <> "" Then
For Each Clf In Sheets("JULY15Release_Dev status").Range("A1:A" & lastRowF)
If UCase(Cle.Value) = UCase(Clf.Value) Then DicInv.Add Cle.Row, ""
Next Clf
End If
Next Cle
'add into dictionary row number from Dev where cell is matched
For Each Clf In Sheets("JULY15Release_Dev status").Range("A1:A" & lastRowF)
If Clf.Value <> "" Then
For Each Cle In Sheets("JULY15Release_Master Inventory").Range("A1:A" & lastRowE)
If UCase(Clf.Value) = UCase(Cle.Value) Then DicDev.Add Clf.Row, ""
Next Cle
End If
Next Clf
'Get mismatch from Inventory
With Sheets("JULY15Release_Master Inventory")
For Each Cle In .Range("A1:A" & lastRowE)
If Not DicInv.exists(Cle.Row) And Cle.Value <> "" Then
.Rows(Cle.Row).Copy Sheets("Mismatch").Rows(lastRowM)
lastRowM = lastRowM + 1
End If
Next Cle
End With
'Get mismatch from Dev
With Sheets("JULY15Release_Dev status")
For Each Clf In .Range("A1:A" & lastRowF)
If Not DicDev.exists(Clf.Row) And Clf.Value <> "" Then
.Rows(Clf.Row).Copy Sheets("Mismatch").Rows(lastRowM)
lastRowM = lastRowM + 1
End If
Next Clf
End With
Application.ScreenUpdating = 1
End Sub
Sample
JULY15Release_Master Inventory
JULY15Release_Dev status
Output Result
Mismatch
Try this, it should work, TESTED.
Sub test()
Dim lrow1 As Long
Dim lrow2 As Long
Dim i As Long
Dim K As Long
Dim j As Long
Dim p As Variant
Dim wb As Workbook
Set wb = ThisWorkbook
K = 2
lrow1 = wb.Sheets("JULY15Release_Master Inventory").Range("A" & Rows.Count).End(xlUp).Row
lrow2 = wb.Sheets("JULY15Release_Dev status").Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lrow1
p = Application.Match(wb.Sheets("JULY15Release_Master Inventory").Range("A" & i).Value, wb.Sheets("JULY15Release_Dev status").Range("A1" & ":" & "A" & lrow2), 0)
If IsError(p) Then
wb.Sheets("JULY15Release_Master Inventory").Rows(i).Copy Destination:=Sheets("Mismatch").Rows(K)
K = K + 1
End If
Next
For j = 1 To lrow2
p = Application.Match(wb.Sheets("JULY15Release_Dev status").Range("A" & j).Value, wb.Sheets("JULY15Release_Master Inventory").Range("A1" & ":" & "A" & lrow1), 0)
If IsError(p) Then
wb.Sheets("JULY15Release_Dev status").Rows(j).Copy Destination:=Sheets("Mismatch").Rows(K)
K = K + 1
End If
Next
End Sub