Dynamic mnacro comparing two tables and adding row if not found on one table or updating info if row found but some info different - excel

I am stuck writing this Excel macro and could kindly use some help. I am trying to create a dynamic macro that will compare two tables in two different sheets and will update information for a row if different or copy a new row to the new table if not there. Both tables contain the same columns of info and have a unique product code per data row. Once a button is pressed, if the product code for the row in table1 is not found on the new table then that row will copy. If the product code is found in the new table but other information in columns is different, than that other information will be updated on the new table. If the product code is found and the other information is the same then that row will not be copied. I need this for as many lines as possible in table1.
NOTE: I thought VLOOKUP may be the route to successfully code this macro...BELOW is my attempt so far to get this to work.
Sub Copy_Attempt()
Application.ScreenUpdating = False
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Raw Data")
Set s2 = Sheets("BAS Linkage Master")
Dim i As Integer
Dim j As Integer
Dim Proj_ID As String
Dim Lookup_Range As Range
Dim Linkage_Lookup_Range As Range
Dim Raw_Percent_Complete As String
Dim Linkage_Percent_Complete As String
Set Lookup_Range = s1.Range("A1:O1000")
Set Linkage_Lookup_Range = s2.Range("A6:N1000")
For i = 2 To 1000
Proj_ID = s1.Range("F" & i).Value
Raw_Percent_Complete = Application.WorksheetFunction.VLookup(Proj_ID, Lookup_Range, 10, False)
Next
For j = 7 To 1000
Linkage_Percent_Complete = s2.Range("I" & j).Value
Next
If Raw_Percent_Complete = Linkage_Percent_Complete Then
' DO NOT COPY THAT ROW OVER
Else
Percent_Complete = Range("I" & j).Value
'UPDATE PERCENT COMPLETE FOR THAT SPECIFIC PRODUCT CODE
End If
Sheets("Raw Data").Activate
Columns("H").EntireColumn.Delete
Range("A2:P1000").Select
Selection.Copy
Sheets("BAS Linkage Master").Activate
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial
' Sheets("Welcome").Activate
' Range("A11:O11").ClearContents
Sheets("Raw Data").Activate
Range("A2:N10000").ClearContents
Application.CutCopyMode = False
Application.ScreenUpdating = True
Sheets("BAS Linkage Master").Activate
End Sub

This is a nice little script that looks for differences and highlights the differences.
Public Sub CompareSheets()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim cell As Range, rng As Range
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set rng = ws1.Range("A1:B20")
For Each cell In rng
Celladdress = cell.Address
If cell <> ws2.Range(Celladdress) Then
cell.Interior.Color = vbYellow
ws2.Range(Celladdress).Interior.Color = vbYellow
End If
Next cell
End Sub
You can use the same concept to copy the values from one table to another.
Public Sub CompareSheets()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim cell As Range, rng As Range
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set rng = ws1.Range("A1:B20")
For Each cell In rng
Celladdress = cell.Address
If cell <> ws2.Range(Celladdress) Then
ws2.Range(Celladdress).Value = ws1.Range(Celladdress).Value
End If
Next cell
End Sub

Related

Excel Row paste with VBA

Hi guys i need some help on VBA.
I have range of numbers in sheet 1 from cells A6:O29. Next I have specific numbers selected in Sheet 3 in Column "B".
[![enter image description here][1]][1]
[![enter image description here][2]][2]
I want to loop throw each value in Sheet 3 Column B and find that specific value in Sheet 1 range A6:O29
Next it should paste Entire Row from Sheet 1 starting From Column (Q:CF) in Sheet 3 Starting from Column C onwards
I have coded it but its not working.
Private Sub CommandButton1_Click()
Dim main As Worksheet
Dim outcome As Worksheet
'main sheet contains Range to search number in
Set main = ThisWorkbook.Sheets("Sheet1")
'outcome sheet has specific values in Column B
Set outcome = ThisWorkbook.Sheets("Sheet3")
'column B values are considrered as doubles
Dim valuesfind As Double
'range where values are to be found
Dim myrange As Range
Set myrange = Worksheets("Sheet1").Range("A6:O29")
'no of times to loop code based on values in outcomesheet
locations = Worksheets("Sheet3").Cells(Rows.Count, 2).End(xlUp).Row
For i = 6 To locations
degrees = outcome.Range("B" & i).Value
For b = 6 To Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
If main.Range("A6:O29" & b).Value = degrees Then
outecome.Range("C:BR" & i).Value = main.Range("Q:CF" & b).Value
Exit For
End If
Next b
Next i
End Sub
[1]: https://i.stack.imgur.com/uBo66m.png
[2]: https://i.stack.imgur.com/D0bRUm.png
Please remember to declare all variables, add Option Explicit at the top of your module to help you enforce it.
Try the code below:
Option Explicit
Private Sub CommandButton1_Click()
'main sheet contains Range to search number in
Dim main As Worksheet
Set main = ThisWorkbook.Sheets("Sheet1")
Const mainCopyRng As String = "Q?:CF?"
'outcome sheet has specific values in Column B
Dim outcome As Worksheet
Set outcome = ThisWorkbook.Sheets("Sheet3")
Const outcomePasteRng As String = "C?:BR?"
'range where values are to be found
Dim myrange As Range
Set myrange = main.Range("A6:O29")
'no of times to loop code based on values in outcomesheet
Dim outcomeLastRow As Long
outcomeLastRow = outcome.Cells(Rows.Count, 2).End(xlUp).Row
Dim i As Long
For i = 6 To outcomeLastRow
Dim Degrees As Double
Degrees = outcome.Cells(i, 2).Value
Dim searchRng As Range
Set searchRng = myrange.Find(Degrees, LookIn:=xlValues, LookAt:=xlWhole)
If Not searchRng Is Nothing Then
Dim searchRow As Long
searchRow = searchRng.Row
outcome.Range(Replace(outcomePasteRng, "?", i)).Value = main.Range(Replace(mainCopyRng, "?", searchRow)).Value
End If
Next i
End Sub
This should work.
Sub Test()
Dim main As Worksheet
Set main = ThisWorkbook.Sheets("Sheet1")
Dim myrange As Range
Set myrange = main.Range("A6:O29")
Dim outcome As Worksheet
Set outcome = ThisWorkbook.Sheets("Sheet3")
'Set reference to locations in sheet3.
Dim locations As Range
With outcome
Set locations = .Range(.Cells(1, 2), .Cells(Rows.Count, 2).End(xlUp))
End With
'Search for each location in Sheet1 and if found copy to Sheet3.
Dim location As Range
Dim FoundLocation As Range
For Each location In locations
Set FoundLocation = myrange.Find( _
What:=location, _
After:=myrange.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext)
If Not FoundLocation Is Nothing Then
main.Cells(FoundLocation.Row, 1).Resize(, 15).Copy _
Destination:=location.Offset(, 1)
End If
Next location
End Sub

How to copy rows based on multiple email addresses?

I have a huge list of data and column 3 contains email addresses.
I'm trying to copy rows based on a mailing list. As long as the row contains one of the email addresses in the mailing list it should be copied to a new sheet.
I have code to copy data based on one email at a time.
I have a userform set up for several email addresses, but this is not efficient.
Here is my code that uses one email address at a time.
Private Sub CommandButton1_Click()
a = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To a
If Worksheets("Sheet1").Cells(i, 3).Value = "<#gmail.com>" Then
Worksheets("Sheet1").Rows(i).Copy
Worksheets("Sheet2").Activate
b = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Sheet2").Cells(b + 1, 1).Select
ActiveSheet.Paste
Worksheets("Sheet2").Activate
End If
Next
Application.CutCopyMode = False
End Sub
How to copy rows based on multiple emails addresses?
I would suggest using the Advanced Filter The destination range will get written in a single step. If you can minimize the number of times your code reads/writes to/from a worksheet, the faster it will run.
Sheet 1
Read the comments in the code as they will be important for modifying it to your real data.
In particular, if your column 3 list does not have the same format as what you have shown in your code, you will need to modify the Criteria range to account for that. The Advanced Filter can also accept wild-cards in the criteria, so this might be another possible approach if your column 3 contains actual email addresses.
Option Explicit
Sub copyWithEmail()
Dim wsSrc As Worksheet, wsDest As Worksheet
Dim rSrc As Range, rDest As Range, rCrit As Range
Dim arrCrit As Variant
Dim I As Long
Set wsSrc = Worksheets("sheet1")
Set wsDest = Worksheets("sheet2")
With wsDest
.Cells.Clear 'optional
Set rCrit = .Cells(1, 250) 'someplace off the screen view
Set rDest = .Cells(1, 1)
End With
'assumes original data starts in A1
'assumes first row is a header row
Set rSrc = wsSrc.Cells(1, 1).CurrentRegion
'can get list of desired emails from user form; range someplace in the workbook; or hard-coded as we have here
arrCrit = Array("gmail.com", "abc.com")
For I = 0 To UBound(arrCrit)
'creating formula that mimics what you show in your code above.
arrCrit(I) = "=" & """=<#" & arrCrit(I) & ">"""
Next I
'create criteria range
'header is same header as in Source Data column 3
Set rCrit = rCrit.Resize(2 + UBound(arrCrit))
rCrit(1) = rSrc(1, 3)
rCrit.Offset(1).Resize(rCrit.Rows.Count - 1) = WorksheetFunction.Transpose(arrCrit)
'Activate wsDest since we will be copying here
wsDest.Activate
rSrc.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=rCrit, CopyToRange:=rDest, Unique:=False
rDest.CurrentRegion.EntireColumn.AutoFit
rCrit.Clear 'get rid of this range
End Sub
Sheet 2
May be something like having Sheet3 of mialList and then
Private Sub CommandButton1_Click()
Dim Sh1 As Worksheet, Sh2 As Worksheet, Sh3 As Worksheet, fnd As Range, cl As Range
Set Sh1 = Worksheets("Sheet1")
Set Sh2 = Worksheets("Sheet2")
Set Sh3 = Worksheets("Sheet3")
Dim mailList As Range
x = Sh3.Range("A" & Sh3.Rows.Count).End(xlUp).Row
Set mailList = Sh3.Range("A2:A" & x)
'Assuming headers in row 1
For Each cl In mailList
b = Sh2.Range("A" & Sh2.Rows.Count).End(xlUp).Row + 1
Set fnd = Sh1.Columns(3).Find(cl)
If Not fnd Is Nothing Then
Sh2.Rows(b).Value = Sh1.Rows(fnd.Row).Value
End If
Next
End Sub

Loop through Excel Sheet

I'm working with two workbooks. In the first I search for the value in the cell to the right of "Charge Number". Take that value and search the second workbooks pivot table for the matching row, copy it and go back to first work book and paste the data. This works great once. But I'm unable to get a loop to look for the next instance of "Charge Number" and repeat the process. The loop I have in the code isn't right because it finds the first value fine but then searches every next row for the same Charge Number.
Sub FindChargeNo()
Dim Loc As Range
Dim ChgNum As String
Dim SrchRng2 As String
Dim pvt As PivotTable
Dim wb As Workbook, ws As Worksheet
Dim FstWB As Workbook
Dim SecWB As Workbook
Dim rng As Range
Set FstWB = Workbooks("First.xlsm")
Set SecWB = Workbooks("Second_test.xlsx")
Set ws1 = FstWB.Worksheets("New Development")
Set ws = SecWB.Worksheets("Aug 18 Report")
Set pvt = ws.PivotTables(1)
lastRow = FstWB.Worksheets("New Development").Range("J" & Rows.Count).End(xlUp).Row
For i = 1 To lastRow
Set Loc = ws1.Cells.Find(What:="Charge Number")
If Not Loc Is Nothing Then
ChgNum = Loc.Offset(0, 1).Value
Debug.Print ChgNum
Debug.Print SrchRng
With pvt.PivotFields("Project WBS").PivotItems(ChgNum).LabelRange
Set rng = ws.Range(.Resize(.Rows.Count, pvt.TableRange1.Columns.Count).Address)
ws.Range(rng.Address).Copy
End With
SrchRng2 = Loc.Offset(0, 5).Address
FstWB.Worksheets("New Development").Range(SrchRng2).PasteSpecial
Set Loc = ws1.Cells.FindNext(Loc)
Loop While Loc.Address <> firstAddress
End If
Next
End Sub

Using VBA to filter a table and copy certain columns to a new sheet

I have a table Named "Combined" which is stored on one sheet of a work book.
On a second sheet I have the following Cell Range (in C1:F2)
Delivery | Column Ref | Column Ref | Available
Delivery ID | I | J | YES
I want to be able to use VBA to filter the table based on the values in this cell range
The Data drop column is a cell with a drop down list which uses VLOOKUP to populate the two column ref cells. These are the two columns that need to be filtered.
Column I needs to show all rows that <>"X" while column J needs to show all rows that equal the value in the available column.
I then need to be able to copy columns A,G and the column that appears in the first reference cell to cell A5 in the second sheet.
Is it possible to do this using VBA? I have been attempting to do this using IF statements, but it is very messy.
I have a piece of code I am attempting to modify from here
Sub Sample()
Dim ws As Worksheet, wsTemp As Worksheet
Dim rRange As Range, rngToCopy As Range
Dim lRow As Long
Dim lRow2 As Long
Dim lCol As Long
'Find the last non-blank cell in column A(1)
lRow2 = Cells(Rows.Count, 1).End(xlUp).Row
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Combined")
With ws
'~~> Set your range for autofilter
Set rRange = .Range("A1:AR" & lRow2)
'~~> Remove any filters
.AutoFilterMode = False
'~~> Filter, copy visible rows to temp sheet
With rRange
.AutoFilter Field:=9, Criteria1:="X"
'~~> This is required to get the visible range
ws.Rows("1:lRow2").EntireRow.Hidden = True
Set rngToCopy = .SpecialCells(xlCellTypeVisible).EntireRow
Set wsTemp = Sheets.Add
rngToCopy.Copy wsTemp.Range("A1")
'~~> Unhide the rows
ws.Rows("1:lRow").EntireRow.Hidden = False
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
Application.DisplayAlerts = False
wsTemp.Delete
Application.DisplayAlerts = True
End Sub
But I do not know how to modify the With rRange section to meet my needs (i.e, Column I <>"X" and column J=F2
Additionally this line ws.Rows("1:lRow2").EntireRow.Hidden = True is giving me a type mismatch error
example of combined table
UPDATE
So my code now looks like this thanks to this thread
Sub AddFilter()
'
' AddFilter Macro
'
Dim rCrit1 As Range, rCrit2 As Range, rCrit3 As Range
Dim copyRange1 As Range, copyRange2 As Range, copyRange3 As Range
Dim filterRange As Range
Dim lastRow As Long
Set src = ThisWorkbook.Sheets("Combined")
Set tgt = ThisWorkbook.Sheets("Dashboard")
lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
Set filterRange = src.Range("A1:Z" & lastRow)
Set copyRange1 = src.Range("A2:A" & lastRow)
Set copyRange2 = src.Range("G2:G" & lastRow)
Set copyRange3 = src.Range("I2:I" & lastRow)
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set rCrit1 = Worksheets("Dashboard").Range("Ref_1")
Set rCrit2 = Worksheets("Dashboard").Range("Ref_2")
Set rCrit3 = Worksheets("Dashboard").Range("Ref_3")
Sheets("Dashboard").Range("A1:C3").ClearContents
Sheets("Dashboard").Range("A1:C3").ClearFormats
Selection.AutoFilter
filterRange.AutoFilter Field:=rCrit1, Criteria1:="<>X"
filterRange.AutoFilter Field:=rCrit2, Criteria1:=rCrit_3
copyRange1.SpecialCells(xlCellTypeVisible).Copy tgt.Range("A5")
copyRange2.SpecialCells(xlCellTypeVisible).Copy tgt.Range("B5")
copyRange3.SpecialCells(xlCellTypeVisible).Copy tgt.Range("C5")
End Sub
However the filterRange.Autofilter line is not reading the rCrit_3 value correctly and so is not filtering based on this (Ref_3 is a named range which contains the YES cell in the first part of the problem).
Additionally the copyRange lines are giving me '1004' runtime error, but if I minimise the spreadsheet and run the code from the VBA window, it will run error free.
Can anyone shed some light on these issues?

Excel expression to copy rows but remove blank rows

I need to copy data from one worksheet into another. However, I need a conditional copy operation that will skip rows based on criteria.
For example, if I start with...
Active Value
yes 1
no 2
no 3
yes 4
no 5
no 6
I only want to copy rows that are Active=yes, so I would end up with...
Value
1
4
Can someone show me how this is done with 1) a macro and 2) a formula?
Formula approach:
suppose your data are in sheet1, range A2:B7.
Then use this formula in sheet2 cell A2:
=IFERROR(INDEX(Sheet1!B:B,SMALL(IF(Sheet1!$A$2:$A$7="yes",ROW(Sheet1!$A$2:$A$7)),ROW()-ROW($A$2)+1)),"")
with array entry (CTRL+SHIFT+ENTER) and then drag it down.
VBA approach:
You can use AutoFilter:
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range, rngToCopy As Range
Dim lastrow As Long
'change Sheet1 and Sheet2 to suit
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
With ws1
'assumung that your data stored in column A:B, Sheet1
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A1:B" & lastrow)
'clear all filters
.AutoFilterMode = False
With rng
'apply filter
.AutoFilter Field:=1, Criteria1:="yes"
On Error Resume Next
'get only visible rows
Set rngToCopy = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
'copy range
If Not rngToCopy Is Nothing Then rngToCopy.Copy Destination:=ws2.Range("A1")
'clear all filters
.AutoFilterMode = False
End With
Application.CutCopyMode = False
End Sub
Note, if you want to copy only Value column, change
Set rngToCopy = .SpecialCells(xlCellTypeVisible)
to
Set rngToCopy = .Offset(, 1).Resize(, .Columns.Count - 1).SpecialCells(xlCellTypeVisible)
It's easy enough with a macro. Assuming you're copying from the first sheet to the second sheet, and that your sample above is in columns A and B, you could do the following:
Public Sub ConditionalCopy()
Dim copyRng As Range
Set copyRng = Worksheets(1).Range("B2:B7")
Dim pasteRng As Range
Set pasteRng = Worksheets(2).Range("A2")
Dim i As Long
i = 0
For Each cell in copyRng.Cells
If cell.Offset(0, -1).Value2 = "yes" Then
pasteRng.Offset(i,0).Value2 = cell.Value2
i = i + 1
End If
Next cell
End Sub
Doing it with a formula presents a challenge in terms of not leaving any blank rows on the second sheet. It would be pretty trivial to just use the following in the second sheet:
=If(A2 = "yes",b2,"")
And copy that down, but you're going to end up with blank rows that you'll have to go back and delete yourself. If you have the ability to use the macro, it's straightforward enough that I would go that route rather than sinking too much effort into devising a formula. The more I think about it, the more I feel like it has to be a programmatic solution to avoid double references.
If you use seperate counters for the source and destination rows, and use cell references rather than ranges the following routine should do the trick
Public Sub copyactivevalue()
Dim i As Integer
Dim j As Integer
Dim acts As Excel.Worksheet
Dim news As Excel.Worksheet
Set acts = Excel.Worksheets("sheet1")
Set news = Excel.Worksheets("sheet2")
With acts
j = 2
For i = 2 To 7
If acts.Cells(i, 1).Value = "yes" Then
news.Cells(j, 1) = acts.Cells(i, 2).Value
j = j + 1
End If
Next
End With
Set acts = Nothing
Set news = Nothing
End Sub
Hope this helps

Resources