I've tasked myself with building a small QA tool, but the problem is that I'm not terribly familiar with VBA or programming. I want to be able to iterate through a single column within three different .csv files. The cells in these columns should match, and the whole point of the tool is to identify the cells that are the "odd man out".
Currently I have some spaghetti code that's giving me an error "false.xlsx" not found...please be gentle...
Sub CompareLists()
Dim count As Integer
Dim kRange As Range
Dim LastRow As Long
Dim iRow As Long
Dim varSheetA As Variant
Dim varSheetB As Variant
Dim varSheetC As Variant
LastRow = Range("A" & Rows.count).End(xlUp).Row
Set kRange = ActiveSheet.Range("A3:A" & LastRow)
Set File_Path1 = Workbooks.Open(Filename = "C:\Test Files\Test_File1.csv")
Set varSheetA = File_Path1.Worksheets("Sheet1").Range(kRange)
Set File_Path2 = Workbooks.Open(Filename = "C:\Test Files\Test_File2.csv")
Set varSheetB = File_Path2.Worksheets("Sheet1").Range(kRange)
Set File_Path3 = Workbooks.Open(Filename = "C:\Test Files\Test_File3.csv")
Set varSheetC = File_Path3.Worksheets("Sheet1").Range(kRange)
For iRow = LBound(varSheetA) To UBound(varSheetA)
count = 1
If varSheetA(iRow) = varSheetB(iRow) Then
count = count + 1
Else
If varSheetA(iRow) = varSheetC(iRow) Then
count = count + 1
Else
If count < 3 Then
ActiveCell.Interior.ColorIndex = 3
End If
End If
End If
Next
End Sub
Your line:
Set File_Path1 = Workbooks.Open(Filename = "C:\Test Files\Test_File1.csv")
Evaluates the inside as a boolean check of whether some nonexistent Filename variable has the value "C:\Test Files\Test_File1.csv". Since the new variable Filename has no value, the comparison returns false. You were probably trying to do := and not =. The := operator assigns to a method parameter while = either does a boolean evaluation or variable assignment. Any one of the following four lines should fix your error as the first use the := operator to assign to the Filename parameter and the last two just know that Filename is the default first parameter.
Set File_Path1 = Workbooks.Open(Filename:="C:\Test Files\Test_File1.csv")
Set File_Path1 = Workbooks.Open Filename:="C:\Test Files\Test_File1.csv"
Set File_Path1 = Workbooks.Open("C:\Test Files\Test_File1.csv")
Set File_Path1 = Workbooks.Open "C:\Test Files\Test_File1.csv"
As a side note, this is something to be very careful about in VBA. Put Option Explicit at the top of every module so that it forces you to define your variables. If you do that, your erroring out line would have complained that variable 'Filename' was not defined.
As far as your next line goes:
Set varSheetA = File_Path1.Worksheets("Sheet1").Range(kRange)
you have two problems. First, when opening a csv file the tab name is always the same as the filename and NOT Sheet1. Second, kRange is part of the worksheet you started on so to get the comparable range on the new sheet you should use kRange.Address. Those fixes change the above into:
Set varSheetA = File_Path1.Worksheets("Test_File1").Range(kRange.Address)
Your loop treats ranges like arrays. The most direct way to fix that is to force them to be arrays by changing the Dim statements (adding parentheses) and the assignment statements for your range variables (removing Set and adding .Value).
Dim varSheetA() As Variant
...
varSheetA = File_Path1.Worksheets("Test_File1").Range(kRange.Address).Value
...
If varSheetA(iRow, 1) = varSheetB(iRow, 1) Then
The best alternative method is to never create the range variables in the first place and just grab cells by row and column indices.
Sub CompareLists_2()
Dim count As Integer
Dim LastRow As Long, iRow As Long
Dim MainSht As Worksheet, ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set MainSht = ActiveSheet
LastRow = MainSht.Range("A" & Rows.count).End(xlUp).Row
Set ws1 = Workbooks.Open(Filename:="C:\Test Files\Test_File1.csv").Worksheets("Test_File1")
Set ws2 = Workbooks.Open(Filename:="C:\Test Files\Test_File2.csv").Worksheets("Test_File2")
Set ws3 = Workbooks.Open(Filename:="C:\Test Files\Test_File3.csv").Worksheets("Test_File3")
For iRow = 3 To LastRow
count = 1
If ws1.Cells(iRow, 1).Value = ws2.Cells(iRow, 1).Value Then
count = count + 1
Else
If ws1.Cells(iRow, 1).Value = ws3.Cells(iRow, 1).Value Then
count = count + 1
Else
If count < 3 Then
MainSht.Cells(iRow, 1).Interior.ColorIndex = 3
End If
End If
End If
Next
End Sub
Of course as far as I can tell your boolean logic reduces to:
If ws1.Cells(iRow, 1).Value <> ws2.Cells(iRow, 1).Value And ws1.Cells(iRow, 1).Value <> ws3.Cells(iRow, 1).Value And ws2.Cells(iRow, 1).Value <> ws3.Cells(iRow, 1).Value Then
MainSht.Cells(iRow, 1).Interior.ColorIndex = 3
End If
Revision of boolean logic per comments (though I'm slightly confused on the logic):
If ws1.Cells(iRow, 1).Value <> ws2.Cells(iRow, 1).Value And ws1.Cells(iRow, 1).Value <> ws3.Cells(iRow, 1).Value And ws2.Cells(iRow, 1).Value <> ws3.Cells(iRow, 1).Value Then
ws1.Cells(iRow, 1).Interior.ColorIndex = 3
ElseIf ws1.Cells(iRow, 1).Value = ws2.Cells(iRow, 1).Value And ws1.Cells(iRow, 1).Value <> ws3.Cells(iRow, 1).Value Then
ws1.Cells(iRow, 1).Interior.ColorIndex = 3
ws2.Cells(iRow, 1).Interior.ColorIndex = 3
End If
Sub CompareLists()
Dim count As Integer
Dim LastRow As Long, iRow As Long
Dim MainSht As Worksheet, ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Dim ws5 As Workbook
Dim var1 As Variant
Set ws1 = Workbooks.Open(Filename:="C:\Test Files\Test_File1.csv").Worksheets("Test_File1")
Set ws2 = Workbooks.Open(Filename:="C:\Test Files\Test_File2.csv").Worksheets("Test_File2")
Set ws3 = Workbooks.Open(Filename:="C:\Test Files\Test_File3.csv").Worksheets("Test_File3")
Set MainSht = ws1
LastRow = MainSht.Range("A" & Rows.count).End(xlUp).Row
For iRow = 3 To LastRow
count = 1
If ws1.Cells(iRow, 1).Value <> ws2.Cells(iRow, 1).Value And ws1.Cells(iRow, 1).Value <> ws3.Cells(iRow, 1).Value Then
ws1.Cells(iRow, 1).Interior.ColorIndex = 3
ElseIf ws1.Cells(iRow, 1).Value = ws2.Cells(iRow, 1).Value And ws1.Cells(iRow, 1).Value <> ws3.Cells(iRow, 1).Value Then
ws1.Cells(iRow, 1).Interior.ColorIndex = 6
ws2.Cells(iRow, 1).Interior.ColorIndex = 6
ElseIf ws1.Cells(iRow, 1).Value = ws3.Cells(iRow, 1).Value And ws1.Cells(iRow, 1).Value <> ws2.Cells(iRow, 1).Value Then
ws1.Cells(iRow, 1).Interior.ColorIndex = 6
ws3.Cells(iRow, 1).Interior.ColorIndex = 6
End If
If ws3.Cells(iRow, 1).Value <> ws2.Cells(iRow, 1).Value And ws3.Cells(iRow, 1).Value <> ws1.Cells(iRow, 1).Value Then
ws3.Cells(iRow, 1).Interior.ColorIndex = 3
ElseIf ws3.Cells(iRow, 1).Value = ws2.Cells(iRow, 1).Value And ws3.Cells(iRow, 1).Value <> ws1.Cells(iRow, 1).Value Then
ws3.Cells(iRow, 1).Interior.ColorIndex = 6
ws2.Cells(iRow, 1).Interior.ColorIndex = 6
End If
If ws2.Cells(iRow, 1).Value <> ws3.Cells(iRow, 1).Value And ws2.Cells(iRow, 1).Value <> ws1.Cells(iRow, 1).Value Then
ws2.Cells(iRow, 1).Interior.ColorIndex = 3
End If
Next
End Sub
Related
I want to delete entire row when all 3 numeric values in cells in columns G,H,I are equal. I wrote a vba code and it does not delete nothing. can Someone advise?
Sub remove_dup()
Dim rng As Range
Dim NumRows As Long
Dim i As Long
Set rng = Range("G2", Range("G2").End(xlDown))
NumRows = Range("G2", Range("G2").End(xlDown)).Rows.Count
For i = 2 To NumRows
Cells(i, 7).Select
If Cells(i, 7).Value = Cells(i, 8).Value = Cells(i, 9).Value Then
EntireRow.Delete
Else
Selection.Offset(1, 0).Select
End If
Next i
End Sub
Try this code. When deleting rows, always start from last row and work towards first one. That way you are sure you wont skip any row.
Sub remove_dup()
Dim rng As Range
Dim NumRows As Long
Dim i As Long
NumRows = Range("G2", Range("G2").End(xlDown)).Rows.Count
For i = NumRows + 1 To 2 Step -1
If Cells(i, 7).Value = Cells(i, 8).Value And Cells(i, 7).Value = Cells(i, 9).Value Then
Cells(i, 7).EntireRow.Delete
Else
End If
Next i
End Sub
Remember when you delete rows, all you need to loop in reverse order.
Please give this a try...
Sub remove_dup()
Dim NumRows As Long
Dim i As Long
NumRows = Cells(Rows.Count, "G").End(xlUp).Row
For i = NumRows To 2 Step -1
If Application.CountIf(Range(Cells(i, 7), Cells(i, 9)), Cells(i, 7)) = 3 Then
Rows(i).Delete
End If
Next i
End Sub
You can delete all rows together using UNION. Try this
Sub remove_dup()
Dim ws As Worksheet
Dim lastRow As Long, i As Long
Dim cel As Range, rng As Range
Set ws = ThisWorkbook.Sheets("Sheet4") 'change Sheet3 to your data range
With ws
lastRow = .Cells(.Rows.Count, "G").End(xlUp).Row 'last row with data in Column G
For i = lastRow To 2 Step -1 'loop from bottom to top
If .Range("G" & i).Value = .Range("H" & i).Value And .Range("G" & i).Value = .Range("I" & i).Value Then
If rng Is Nothing Then 'put cell in a range
Set rng = .Range("G" & i)
Else
Set rng = Union(rng, .Range("G" & i))
End If
End If
Next i
End With
rng.EntireRow.Delete 'delete all rows together
End Sub
I want to run a script to find cells highlighted yellow, on Sheet1 and if yellow, copy/paste to Sheet2. The code below seems like it should work, but it's failing on this line.
rc.Copy rd
Basically, I would like to concatenate values in Columns 2, 3, and 17, on Sheet1, and copy/paste everything to Sheet2. I'm guessing that I'm missing some kind of Worksheet reference, but I don't know for sure, and so far nothing has worked for me. But...I think this is pretty close!! Any help is appreciated!
Sub ColorCopier()
Dim i As Long
Dim j As Long
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ThisWorkbook.Worksheets("Version Control")
LRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row + 1
'k = 1
Set rc = Sheets("Cobrand Tasklist").UsedRange
For i = 1 To rc.Rows.Count
For j = 1 To rc.Columns.Count
If Cells(i, j).Interior.ColorIndex = 6 Then
If j = 2 Then
Set rc = Cells(i, j)
Set rd = Sheets("Version Control").Cells(LRow, 4)
rc = "Task #" & rc
rc.Copy rd
End If
If j = 3 Then
Set rc = Cells(i, j)
Set rd = Sheets("Version Control").Cells(LRow, 4)
rc = "Task Title " & rc
rc.Copy rd
End If
If j = 17 Then
Set rc = Cells(i, j)
Set rd = Sheets("Version Control").Cells(LRow, 4)
rc = "Task Description " & rc
rc.Copy rd
End If
LRow = LRow + 1
End If
Next
Next
End Sub
You really could condense the code down to stop repeating the same code. But , I left it the way you have done it to illustrate a different way of doing what I think you are trying to do.
Dim i As Long
Dim j As Long
Dim sht As Worksheet
Dim LastRow As Long
Dim rng As Range
Dim str As String
Dim rng As Range
'
Set sht = ThisWorkbook.Worksheets("Version Control")
LRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row + 1
'k = 1
Set rc = Sheets("Cobrand Tasklist").UsedRange
For i = 1 To rc.Rows.Count
For j = 1 To rc.Columns.Count
If Cells(i, j).Interior.ColorIndex = 6 Then
If j = 2 Then
Cells(i, j).Value = "Task #" & Cells(i, j).Value
If Not rng Is Nothing Then Set rng = Union(rng, Cells(i, j)) Else Set rng = Cells(i, j)
End If
If j = 3 Then
Cells(i, j).Value = "Task Title " & Cells(i, j).Value
If Not rng Is Nothing Then Set rng = Union(rng, Cells(i, j)) Else Set rng = Cells(i, j)
End If
If j = 17 Then
Cells(i, j).Value = "Task Description " & Cells(i, j).Value
If Not rng Is Nothing Then Set rng = Union(rng, Cells(i, j)) Else Set rng = Cells(i, j)
End If
LRow = LRow + 1
End If
Next
Next
rng.Copy Sheets("Version Control").Cells(LRow, 4)
Doing the copy and paste on one line instead of every time inside the loop will speed up your code enormously.
I had someone help me make the initial code for this, Im trying to modify it however its wrong.
I need to compare sheet 2 in a spreadsheet to sheets 4 to 10 and if the values of row e or b do not match any other row. copy the entire row to the bottom of sheet 1.
This is what I have so far but the value isn't being set to true and it prints after every sheet. I'm stick
Sub Button13() 'merge
Dim lastSourceRow As Long, LastTargetRow As Long, allSheets As Long, lastSheet As Long
Dim source As String, TARGET As Integer
Dim tempVal As String, tempValE, tempValT
Dim tRow As Long, lRow As Long, lCol As Long, nRow As Long
Dim match As Boolean
source = "Sheet2"
lastSheet = "10"
lastSourceRow = Sheets(source).Range("A" & Rows.Count).End(xlUp).Row
For allSheets = 1 To lastSheet
TARGET = allSheets
LastTargetRow = Sheets(TARGET).Range("A" & Rows.Count).End(xlUp).Row
For lRow = 2 To lastSourceRow 'Loop through Rows on currentsheet
Count = "0"
match = False 'Reset boolean test for each new row
tempVal = Sheets(source).Cells(lRow, "B").Value 'Assign the tempValue to compare
tempValE = Sheets(source).Cells(lRow, "E").Value
For tRow = 2 To LastTargetRow 'Loop through entire target sheet
tempValT = Sheets(TARGET).Cells(tRow, "B").Value
If (allSheets <> 2 Or allSheets <> 3) And tempVal = Sheets(TARGET).Cells(tRow, "B").Value And tempValE = Sheets(TARGET).Cells(tRow, "E").Value Then
match = True
ElseIf (allSheets <> 2 Or allSheets <> 3) And tempVal = Sheets(TARGET).Cells(tRow, "B").Value And tempValE = "" Then
match = True
ElseIf (allSheets <> 2 Or allSheets <> 3) And tempVal = Sheets(TARGET).Cells(tRow, "B").Value Then
match = True
'ElseIf Sheets(TARGET).Cells(tRow, "G").Value < DateAdd("m", -5, Date) Then
'match = True
End If
Next tRow
If match = False Then 'No Match found, copy row
nRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
For lCol = 1 To 26 'Copy entire row by looping through 6 columns
Sheets("Sheet1").Cells(nRow, lCol).Value = Sheets(source).Cells(lRow, lCol).Value
Next lCol
End If
Next lRow
Next allSheets
End Sub
You have 2 problems:
problem 1: you reset match = False inside the lRow loop, this must be inside the tRow loop, otherwise if the first match = True hits then match is never reset
problem 2: If match = False Then can't be entered because it is outside of your tRow loop. so match is set inside the loop but can not be reached by If match = False Then
so the working code should be
Sub Button13() 'merge
Dim lastSourceRow As Long, LastTargetRow As Long, allSheets As Long, lastSheet As Long
Dim source As String, TARGET As Integer
Dim tempVal As String, tempValE, tempValT
Dim tRow As Long, lRow As Long, lCol As Long, nRow As Long
Dim match As Boolean
source = "Sheet2"
lastSheet = "10"
lastSourceRow = Sheets(source).Range("A" & Rows.Count).End(xlUp).Row
For allSheets = 1 To lastSheet
TARGET = allSheets
LastTargetRow = Sheets(TARGET).Range("A" & Rows.Count).End(xlUp).Row
For lRow = 2 To lastSourceRow 'Loop through Rows on currentsheet
Count = "0"
tempVal = Sheets(source).Cells(lRow, "B").Value 'Assign the tempValue to compare
tempValE = Sheets(source).Cells(lRow, "E").Value
For tRow = 2 To LastTargetRow 'Loop through entire target sheet
tempValT = Sheets(TARGET).Cells(tRow, "B").Value
If (allSheets <> 2 Or allSheets <> 3) And tempVal = Sheets(TARGET).Cells(tRow, "B").Value And tempValE = Sheets(TARGET).Cells(tRow, "E").Value Then
match = True
ElseIf (allSheets <> 2 Or allSheets <> 3) And tempVal = Sheets(TARGET).Cells(tRow, "B").Value And tempValE = "" Then
match = True
ElseIf (allSheets <> 2 Or allSheets <> 3) And tempVal = Sheets(TARGET).Cells(tRow, "B").Value Then
match = True
'ElseIf Sheets(TARGET).Cells(tRow, "G").Value < DateAdd("m", -5, Date) Then
'match = True
End If
If match = False Then 'No Match found, copy row
nRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
For lCol = 1 To 26 'Copy entire row by looping through 6 columns
Sheets("Sheet1").Cells(nRow, lCol).Value = Sheets(source).Cells(lRow, lCol).Value
Next lCol
End If
'2 moved lines
match = False 'Reset boolean test for each new row
Next tRow
Next lRow
Next allSheets
End Sub
I have a workbook that has 2 worksheets and sub-sheets Named as per Product Line Column:
NEW DATA sheet
Master Table sheet ("DBQ Query Result")
Subsheets (Driling and Workover, Fishing, Liner Systems, Professional Services, Wellbore Cleaning)
They both have same headers, within the column headers there is a uniqueID column.
PART A
I would like to match uniqueID between those 2 sheets and:
When there is a match, compare row cell values for each column and update if there is difference
When there is a uniqueID in NEW DATA sheet that does not exist in Master Table, I would like this whole row associated to this uniqueId to be copied to Master Table sheet
PART B
I would like to have a new button that when pressed, UniqueID from Master Page will be compared with Unique Id column of each subsheet and:
When there is a match, update subsheet row according to UNIQUEID
When there is no match, that means a new UNIQUEID is created and this should be added to its corresponding subsheet as a last row
I would like to accomplish the above using VBA macro please. I have attached a sample of the excel https://dl.dropboxusercontent.com/u/29585269/Sample.xlsx.
Please let me know if you need any additional information.
I came across few codes online and modified them to fit my need.
So, this is how it goes:
You have 3 Main Sheets next to your PL Sheets - Subsheets (Driling and Workover, Fishing, Liner Systems, Professional Services, Wellbore Cleaning):
Original
Updated
Changes
This code will print the changes between Original Sheet and Updated Sheet:
Option Explicit
Sub CompareSheets()
'
' constants
' worksheets & ranges
' original
Const ksWSOriginal = "ORIGINAL"
Const ksOriginal = "OriginalTable"
Const ksOriginalKey = "OriginalKey"
' updated
Const ksWSUpdated = "UPDATED"
Const ksUpdated = "UpdatedTable"
Const ksUpdatedKey = "UpdatedKey"
' changes
Const ksWSChanges = "CHANGES"
Const ksChanges = "ChangesTable"
' labels
Const ksChange = "CHANGE"
Const ksRemove = "REMOVE"
Const ksAdd = "ADD"
'
' declarations
Dim rngO As Range, rngOK As Range, rngU As Range, rngUK As Range, rngC As Range
Dim c As Range
Dim I As Long, J As Long, lChanges As Long, lRow As Long, bEqual As Boolean
'
' start
Set rngO = Worksheets(ksWSOriginal).Range(ksOriginal)
Set rngOK = Worksheets(ksWSOriginal).Range(ksOriginalKey)
Set rngU = Worksheets(ksWSUpdated).Range(ksUpdated)
Set rngUK = Worksheets(ksWSUpdated).Range(ksUpdatedKey)
Set rngC = Worksheets(ksWSChanges).Range(ksChanges)
With rngC
If .Rows.Count > 1 Then
Range(.Rows(2), .Rows(.Rows.Count)).ClearContents
Range(.Rows(2), .Rows(.Rows.Count)).Font.ColorIndex = xlColorIndexAutomatic
Range(.Rows(2), .Rows(.Rows.Count)).Font.Bold = False
End If
End With
'
' process
lChanges = 1
' 1st pass: updates & deletions
With rngOK
For I = 5 To .Rows.Count
Set c = rngUK.Find(.Cells(I, 1).Value, , xlValues, xlWhole)
If c Is Nothing Then
' deletion
lChanges = lChanges + 1
rngC.Cells(lChanges, 1).Value = ksRemove
For J = 1 To rngO.Columns.Count
rngC.Cells(lChanges, J + 1).Value = rngO.Cells(I, J).Value
rngC.Cells(lChanges, J + 1).Font.Color = vbRed
rngC.Cells(lChanges, J + 1).Font.Bold = True
Next J
Else
bEqual = True
lRow = c.Row - rngUK.Row + 1
For J = 1 To rngO.Columns.Count
If rngO.Cells(I, J).Value <> rngU.Cells(lRow, J).Value Then
bEqual = False
Exit For
End If
Next J
If Not bEqual Then
' change
lChanges = lChanges + 1
rngC.Cells(lChanges, 1).Value = ksChange
For J = 1 To rngO.Columns.Count
If rngO.Cells(I, J).Value = rngU.Cells(lRow, J).Value Then
rngC.Cells(lChanges, J + 1).Value = rngO.Cells(I, J).Value
Else
rngC.Cells(lChanges, J + 1).Value = rngU.Cells(I, J).Value
rngC.Cells(lChanges, J + 1).Font.Color = vbMagenta
rngC.Cells(lChanges, J + 1).Font.Bold = True
End If
Next J
End If
End If
Next I
End With
' 2nd pass: additions
With rngUK
For I = 5 To .Rows.Count
Set c = rngOK.Find(.Cells(I, 1).Value, , xlValues, xlWhole)
If c Is Nothing Then
' addition
lChanges = lChanges + 1
rngC.Cells(lChanges, 1).Value = ksAdd
For J = 1 To rngU.Columns.Count
rngC.Cells(lChanges, J + 1).Value = rngU.Cells(I, J).Value
rngC.Cells(lChanges, J + 1).Font.Color = vbBlue
rngC.Cells(lChanges, J + 1).Font.Bold = True
Next J
End If
Next I
End With
'
' end
Worksheets(ksWSChanges).Activate
rngC.Cells(2, 3).Select
Set rngC = Nothing
Set rngUK = Nothing
Set rngU = Nothing
Set rngOK = Nothing
Set rngO = Nothing
Beep
'
End Sub
This Button Code will Apply Updates to rows noted as "Changes" and "Add" (I dont care about Remove)
Sub Update()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim tempName As String
Dim lastRow1 As Long, lastRow2 As Long
Dim s2Row As Long, s1Row As Long
Application.ScreenUpdating = False
Set sh1 = ActiveWorkbook.Worksheets("ORIGINAL")
Set sh2 = ActiveWorkbook.Worksheets("CHANGES")
lastRow1 = sh1.Cells(Rows.Count, "A").End(xlUp).Row 'Get last row for both sheets
lastRow2 = sh2.Cells(Rows.Count, "A").End(xlUp).Row ' searching both
For s2Row = 2 To lastRow2 'Loop through "CHANGES"
If sh2.Cells(s2Row, 1).Value = "CHANGE" Then
tempName = sh2.Cells(s2Row, 2).Value 'extra step for understanding concept
'There is a match, so now
For s1Row = 2 To lastRow1 'Search through the other sheet
If sh1.Cells(s1Row, 1).Value = tempName Then
For I = 2 To 35
sh1.Cells(s1Row, I).Value = sh2.Cells(s2Row, I + 1).Value 'Copy Values
Next I
End If
Next s1Row
End If
Next s2Row
For s2Row = 2 To lastRow2
If sh2.Cells(s2Row, 1).Value = "ADD" Then
sh2.Range("B" & s2Row & ":BB" & s2Row).Copy 'Copy rows
sh1.Rows(lastRow1 + 1).Insert Shift:=xlDown 'Insert rows
sh1.Cells(lastRow1 + 1, 78).Value = "ADD" 'Classify the row as newly added
End If
Next s2Row
Application.ScreenUpdating = True
Sheets("ORIGINAL").Activate
End Sub
And this button will apply updates to PL Cell Values for existing UniqueIDs changes
Sub Update_PL()
Dim ws As Worksheet
Dim lastRng As Range
Application.ScreenUpdating = False 'speed up code
'Added to loop through all UniqueIDs and update accordingly
Dim sh1 As Worksheet, sh2 As Worksheet
Dim tempName As String
Dim lastRow1 As Long, lastRow2 As Long
Dim s2Row As Long, s1Row As Long
'No Longer requires clearing screen, we will match unique ids and update/add as necessary
'ThisWorkbook.Sheets("ORIGINAL").Rows("5:65536").ClearContents 'clear
Set sh1 = ActiveWorkbook.Worksheets("ORIGINAL") 'Define Master Table
Set sh2 = ws 'Selects Active Sheet
For Each ws In ThisWorkbook.Worksheets
Set lastRng = ThisWorkbook.Sheets("ORIGINAL").Range("A65536").End(xlUp).Offset(1, 0)
Select Case ws.Name
Case "ORIGINAL" 'exlude
Case "UPDATED" 'exlude
Case "CHANGES" 'exlude
Case "Report Table" 'exlude
Case "DASHBOARD" 'exlude
'do nothing
Case Else
ws.Activate
lastRow2 = sh1.Cells(Rows.Count, "A").End(xlUp).Row 'Count Master Table Rows to extract Last Row #
With ActiveSheet
lastRow1 = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row 'Count Active Sheet Rows to extract Last Row #
End With
For s2Row = 2 To lastRow2 'Loop through Active WorkSheet
tempName = sh1.Cells(s2Row, 1).Value 'Define UniqueID to loop
tempPL = sh1.Cells(s2Row, 22).Value 'Define PL to loop
For s1Row = 2 To lastRow1 'Match UniqueIDs between Master sheet and Active Sheet
If ActiveSheet.Cells(s1Row, 1).Value = tempName Then 'If Matches TRUE then
For I = 2 To 35 'Loop all Columns and update as necessary
ActiveSheet.Cells(s1Row, I).Value = sh1.Cells(s2Row, I).Value 'Copy Values
Next I
End If
Next s1Row
Next s2Row
'copy data from individual sheets
'Range("A2", Range("AB65536").End(xlUp)).Copy lastRng
End Select
Next
Application.CutCopyMode = False 'clear clipboard
Application.ScreenUpdating = True
Sheets("ORIGINAL").Activate
End Sub
And this last button is used to Add new UniqueIDs to corresponding PL
Sub Add_Rows()
Dim ws As Worksheet
Dim lastRng As Range
Application.ScreenUpdating = False 'speed up code
'Added to loop through all UniqueIDs and update accordingly
Dim sh1 As Worksheet
Dim tempPL As String
Dim lastRow1 As Long, lastRow2 As Long
Dim s2Row As Long, s1Row As Long
Set sh1 = ActiveWorkbook.Worksheets("ORIGINAL") 'Define Master Table
For Each ws In ThisWorkbook.Worksheets
Set lastRng = ThisWorkbook.Sheets("ORIGINAL").Range("A65536").End(xlUp).Offset(1, 0)
Select Case ws.Name
Case "ORIGINAL" 'exlude
Case "UPDATED" 'exlude
Case "CHANGES" 'exlude
Case "Report Table" 'exlude
Case "DASHBOARD" 'exlude
'do nothing
Case Else
ws.Activate
lastRow2 = sh1.Cells(Rows.Count, "A").End(xlUp).Row 'Count Master Table Rows to extract Last Row #
With ActiveSheet
lastRow1 = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row 'Count Active Sheet Rows to extract Last Row #
End With
For s2Row = 5 To lastRow2 'Loop through Active WorkSheet
If sh1.Cells(s2Row, 78).Value = "ADD" Then
tempPL = sh1.Cells(s2Row, 23).Value
If ActiveSheet.Name = tempPL Then
sh1.Range("A" & s2Row & ":AB" & s2Row).Copy 'Copy rows
ActiveSheet.Rows(lastRow1 + 1).Insert Shift:=xlDown 'Insert rows
sh1.Cells(s2Row, 78).Value = "ADDED" 'Validate Row has been added in Master Sheet
End If
End If
Next s2Row
End Select
Next
Application.CutCopyMode = False 'clear clipboard
Application.ScreenUpdating = True 'Resume ScreenUpdating
Sheets("ORIGINAL").Activate 'Display Original Sheet
End Sub
Complicated? Yeah... but solved my issue.
BR! Eddy
I would like to change some Book2 value with respect to Book1's value.
Macro code in Book1:
Dim i As Integer
Dim k As Integer
k = Range("Z1")
For i = 1 To k
If Cells(i, 22).Value = "Yes" Then
Windows("Book2").Activate
Cells(i, 11) = ""
Cells(i, 13) = ""
End If
Next i
As commented, you can try re-writing your code like this:
Dim i As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Workbooks("Book1").Sheets("Sheet1") '~~> change sheet name to suit
Set ws2 = Workbooks("Book2").Sheets("Sheet1")
With ws1
For i = 1 to .Range("Z1").Value
If .Cells(i, 22).Value = "Yes" Then
ws2.Cells(i, 11).Value = ""
ws2.Cells(i, 13).Value = ""
End If
Next
End With