I am trying to write a script that will compare two workbooks that each have 80 sheets. The sheet names will match in both workbooks (one workbook is a prod copy, one is a copy from a UAT environment. All data should be same). I was able to run a script that will compare the sheet I specify, but I'm having difficulty trying to figure out how to write it to compare each sheet.
Sub CompareWorksheets()
Dim varSheetA As Worksheet
Dim varSheetB As Worksheet
Dim varSheetAr As Variant
Dim varSheetBr As Variant
Dim strRangeToCheck As String
Dim iRow As Long
Dim iCol As Long
Dim wbkc As Workbook
Set wbkc = ThisWorkbook 'this is where results of comparison will be documented
Set wbka = Workbooks.Open(Filename:="C:\Users\Desktop\dashboard1.xlsx") 'PROD
Set wbkb = Workbooks.Open(Filename:="C:\Users\Desktop\dashboard2.xlsx") 'UAT
Set varSheetA = wbka.Worksheets("Members")
Set varSheetB = wbkb.Worksheets("Members")
strRangeToCheck = ("A5:A10")
varSheetAr = varSheetA.Range(strRangeToCheck).Value
varSheetBr = varSheetB.Range(strRangeToCheck).Value
erow = 6 'starting row to document summary results
For iRow = LBound(varSheetAr, 1) To UBound(varSheetAr, 1)
For iCol = LBound(varSheetAr, 2) To UBound(varSheetAr, 2)
If varSheetAr(iRow, iCol) = varSheetBr(iRow, iCol) Then
varSheetA.Cells(iRow, iCol).Interior.ColorIndex = xlNone
varSheetB.Cells(iRow, iCol).Interior.ColorIndex = xlNone
Else
varSheetA.Cells(iRow, iCol).Interior.ColorIndex = 22
varSheetB.Cells(iRow, iCol).Interior.ColorIndex = 22
wbkc.Activate
erow = erow + 1
wbkc.Sheets("Summary").Cells(erow, 2) = iRow
wbkc.Sheets("Summary").Cells(erow, 3) = iCol
wbkc.Sheets("Summary").Cells(erow, 4) = varSheetA.Cells(iRow, iCol)
wbkc.Sheets("Summary").Cells(erow, 5) = varSheetB.Cells(iRow, iCol)
End If
Next
Next
End Sub
You need to iterate through the Worksheets of one of the workbooks and use the worksheet names to set worksheet variable for the second workbook.
Sub CompareWorksheets()
Dim wbPROD As Workbook, wbUAT As Workbook, wbSummary As Workbook
Dim wsPROD As Worksheet, wsUAT As Worksheet, wsSummary As Worksheet
Dim arrPROD As Variant, arrUAT As Variant
Dim strRangeToCheck As String
Dim iRow As Long, iCol As Long
Set wbSummary = ThisWorkbook 'this is where results of comparison will be documented
Set wsSummary = wbkc.Sheets("Summary")
Set wbPROD = Workbooks.Open(Filename:="C:\Users\Desktop\dashboard1.xlsx") 'PROD
Set wbUAT = Workbooks.Open(Filename:="C:\Users\Desktop\dashboard2.xlsx") 'UAT
strRangeToCheck = ("A5:A10")
erow = 6 'starting row to document summary results
For Each wsPROD In wbPROD.Worksheets
Set wsUAT = wbUAT.Worksheets(wsPROD.Name)
arrPROD = wsPROD.Range(strRangeToCheck).Value
arrUAT = wsUAT.Range(strRangeToCheck).Value
For iRow = LBound(arrPROD, 1) To UBound(arrPROD, 1)
For iCol = LBound(arrPROD, 2) To UBound(arrPROD, 2)
If arrPROD(iRow, iCol) = arrUAT(iRow, iCol) Then
wsPROD.Cells(iRow, iCol).Interior.ColorIndex = xlNone
wsUAT.Cells(iRow, iCol).Interior.ColorIndex = xlNone
Else
wsPROD.Cells(iRow, iCol).Interior.ColorIndex = 22
wsUAT.Cells(iRow, iCol).Interior.ColorIndex = 22
wbkc.Activate
erow = erow + 1
With wsSummary
.Cells(erow, 2) = iRow
.Cells(erow, 3) = iCol
.Cells(erow, 4) = wsPROD.Cells(iRow, iCol)
.Cells(erow, 5) = wsUAT.Cells(iRow, iCol)
End With
End If
Next
Next
Next
End Sub
Start with
Option Explicit ' to force you to declare for each variable
Add code to delete prior errors
Dim wbkc As Workbook, LastRow as Long, nRow as Long
wbkc.Sheets("Summary").UsedRange 'Refresh UsedRange
LastRow = wbkc.Sheets("Summary").UsedRange.Rows(wbkc.Sheets("Summary").UsedRange.Rows.Count).Row
For nRow = LastRow to eRow + 1 step -1
wbkc.Sheets("Summary").Rows(nRow).Delete
Next nRow
Basically, google "excel vba for each sheet" and look at the first one
https://stackoverflow.com/questions/21918166/excel-vba-for-each-worksheet-loop
to get the driving code (ignoring resizingColumns) and create CompareCells.
Sub forEachWs()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
Call CompareCells(ws)
Next
End Sub
Sub CompareCells(ws as Worksheet)
End Sub
Finally, Add your code inside of CompareCells
Giving (PLEASE test this code, since we do not have wbka or wbkb excel files)
Option Explicit ' to force you to declare for each variable
' define output -- this is where results of comparison will be documented
Dim wbkc As Workbook, eRow as long, LastRow as Long, nRow as Long
Set wbkc = ThisWorkbook
eRow = 6 'starting row to document summary results
wbkc.Sheets("Summary").UsedRange 'Refresh UsedRange
LastRow = wbkc.Sheets("Summary").UsedRange.Rows(wbkc.Sheets("Summary").UsedRange.Rows.Count).Row
For nRow = LastRow to eRow + 1 step -1
wbkc.Sheets("Summary").Rows(nRow).Delete ' delete prior errors
Next nRow
' define inputs --
Dim wbka As Workbook, wbkb As Workbook
Set wbka = Workbooks.Open(Filename:="C:\Users\Desktop\dashboard1.xlsx") 'PROD
Set wbkb = Workbooks.Open(Filename:="C:\Users\Desktop\dashboard2.xlsx") 'UAT
' step thru each sheet
Dim ws As Worksheet
For Each ws In wbka.Worksheets
'
Dim varSheetA As Worksheet, varSheetB As Worksheet
Dim varSheetAr As Variant, varSheetBr As Variant
Dim strRangeToCheck As String
Set varSheetA = wbka.Worksheets(ws.Name)
Set varSheetB = wbkb.Worksheets(ws.Name)
strRangeToCheck = ("A5:A10")
varSheetAr = varSheetA.Range(strRangeToCheck).Value
varSheetBr = varSheetB.Range(strRangeToCheck).Value
' step thru each cell
Dim iRow As Long, iCol As Long
For iRow = LBound(varSheetAr, 1) To UBound(varSheetAr, 1)
For iCol = LBound(varSheetAr, 2) To UBound(varSheetAr, 2)
If varSheetAr(iRow, iCol) = varSheetBr(iRow, iCol) Then
varSheetA.Cells(iRow, iCol).Interior.ColorIndex = xlNone
varSheetB.Cells(iRow, iCol).Interior.ColorIndex = xlNone
Else
varSheetA.Cells(iRow, iCol).Interior.ColorIndex = 22
varSheetB.Cells(iRow, iCol).Interior.ColorIndex = 22
wbkc.Activate
erow = erow + 1
wbkc.Sheets("Summary").Cells(erow, 1) = ws.Name 'ADDed
wbkc.Sheets("Summary").Cells(erow, 2) = iRow
wbkc.Sheets("Summary").Cells(erow, 3) = iCol
wbkc.Sheets("Summary").Cells(erow, 4) = varSheetA.Cells(iRow, iCol)
wbkc.Sheets("Summary").Cells(erow, 5) = varSheetB.Cells(iRow, iCol)
End If
Next iCol
Next iRow
Next ws
Related
Need some solution in VBA ->If the blank value in column A then takes value from column B.
I wrote some code, but I don't have any idea why this is not working.
dim LastR as Long
LastR = Worksheets("Sheet1").Range("BU" & Worksheets("Sheet1").Rows.Count).End(xlUp).Row
dim i as long
For i = LastR To 2 Step -1
If IsEmpty(Cells(i, "a")) Then Cells(i, "a").Value = Cells(i, "b").Value
Next i
You should check if the value is empty.
See two examples:
Dim LastR As Long
LastR = Worksheets("Sheet1").Range("BU" & Worksheets("Sheet1").Rows.Count).End(xlUp).Row
Dim i As Long
For i = LastR To 2 Step -1
'If Sheets("Sheet1").Cells(i, "a") = "" Then Sheets("Sheet1").Cells(i, 1).Value = Cells(i, 2).Value
If IsEmpty(Sheets("Sheet1").Cells(i, "a").Value) = True Then Sheets("Sheet1").Cells(i, 1).Value = Cells(i, 2).Value
Next i
Loop Through the Cells of a Column
All three versions do the same and are about equally efficient.
Option Explicit
Sub FillEmptiesConstants()
Const wsName As String = "Sheet1" ' Worksheet Name
Const fRow As Long = 2 ' First Row
Const lrCol As String = "BU" ' Last Row Column
Const lCol As String = "A" ' Lookup Column
Const dCol As String = "A" ' Destination Column
Const sCol As String = "B" ' Source Column
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, lrCol).End(xlUp).Row
If lRow < fRow Then Exit Sub
Dim r As Long
For r = fRow To lRow
If IsEmpty(ws.Cells(r, lCol)) Then
ws.Cells(r, dCol).Value = ws.Cells(r, sCol).Value
End If
Next r
End Sub
Sub FillEmptiesSimple()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, "BU").End(xlUp).Row
If lRow < 2 Then Exit Sub
Dim r As Long
For r = 2 To lRow
If IsEmpty(ws.Cells(r, "A")) Then
ws.Cells(r, "A").Value = ws.Cells(r, "B").Value
End If
Next r
End Sub
Sub FillEmptiesSimpleWith()
With ThisWorkbook.Worksheets("Sheet1")
Dim lRow As Long: lRow = .Cells(.Rows.Count, "BU").End(xlUp).Row
If lRow < 2 Then Exit Sub
Dim r As Long
For r = 2 To lRow
If IsEmpty(.Cells(r, "A")) Then
.Cells(r, "A").Value = .Cells(r, "B").Value
End If
Next r
End With
End Sub
I am having a hard time getting the below logic to work. The issue seems to be where the Year function is placed. It seems to be skipping over the logic completely, yet i'm not sure how to encorporate the year function without breaking the with loop.
Sub BlankLine()
Dim Col_year As Variant
Dim Col_st As Variant
Dim Col_btc As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Dim ws As Worksheet
Dim wb As Workbook
Dim state_ar() As Variant
Col_year = "E"
Col_st = "C"
Col_btc = "D"
StartRow = 1
BlankRows = 1
Set wb = ThisWorkbook
Set ws = wb.Worksheets("LU_WK_BENE_AMT")
LastRow = ws.Cells(Rows.Count, Col_year).End(xlUp).Row
Application.ScreenUpdating = False
state_ar = Array("02", "03")
For Each State In state_ar
With ws
For R = LastRow To StartRow + 1 Step -1
If Year(.Cells(R, Col_year).Value) = 2020 And .Cells(R, Col_st) = i Then
.Cells(R + 1, Col_year).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col_year).Value = 2021
.Cells(R + 1, Col_st).Value = .Cells(R, Col_st).Value
.Cells(R + 1, Col_btc).Value = .Cells(R, Col_btc).Value
End If
Next R
End With
Next
Application.ScreenUpdating = True
End Sub
I am trying to build a macro that goes through my data set and checks if there's any text in column W, if it does I would like the macro to duplicate the row beneath it, then move the values from Columns X and W to U and Q respectively.
My code at the moment is only trying to get the duplicate part down but its not working and I'm kind of stuck, could you have a look at it and help out?
Dim lastRow2 as Long
Dim cel as Range, srchRng as Range
lastRow2 = Worksheets("UPLOAD COPY").Cells(Rows.Count, 23).End(xlUp).Row
Set srchRng = Range("W2: W" & lastRow2)
For Each cel In srchRng
If InStr(1, cel.Value, "*") > 0 Then
cel.Offset(1).Insert
cel.EntireRow.Copy cel.Offset(1)
Set cel = cel.Offset(2)
End If
Next cel
Create Duplicate Rows
Option Explicit
Sub createDuplicateRows()
Const wsName As String = "UPLOAD COPY"
Const FirstRow As Long = 2
Const Col As Variant = "W" ' or 23
Dim OldCols As Variant: OldCols = Array("W", "X") ' or 23, 24
Dim NewCols As Variant: NewCols = Array("Q", "U") ' or 17, 21
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
Dim CurrentRow As Long: CurrentRow = FirstRow
Dim j As Long
Do
If ws.Cells(CurrentRow, Col).Value <> "" Then GoSub insertRow
CurrentRow = CurrentRow + 1
Loop Until CurrentRow > LastRow
Exit Sub
insertRow:
ws.Rows(CurrentRow + 1).EntireRow.Insert Shift:=xlDown
ws.Rows(CurrentRow).EntireRow.Copy ws.Rows(CurrentRow + 1)
CurrentRow = CurrentRow + 1
GoSub changeValues
LastRow = LastRow + 1
Return
changeValues:
For j = 0 To UBound(OldCols)
ws.Cells(CurrentRow, NewCols(j)).Value _
= ws.Cells(CurrentRow, OldCols(j)).Value
ws.Cells(CurrentRow, OldCols(j)).ClearContents
Next j
Return
End Sub
EDIT:
You can write the 'delete part' in a separate subroutine. Then you can do what I suggested in the comments. Sorry, I didn't realize that previously it would copy the already cleared (empty) values.
Option Explicit
Sub createDuplicateRows()
Const wsName As String = "UPLOAD COPY"
Const FirstRow As Long = 2
Const Col As Variant = "W" ' or 23
Dim OldCols As Variant: OldCols = Array("W", "X", "X") ' or 23, 24, 24
Dim NewCols As Variant: NewCols = Array("Q", "U", "Y") ' or 17, 21, 25
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
Dim CurrentRow As Long: CurrentRow = FirstRow
Dim j As Long
Do
If ws.Cells(CurrentRow, Col).Value <> "" Then GoSub insertRow
CurrentRow = CurrentRow + 1
Loop Until CurrentRow > LastRow
Exit Sub
insertRow:
ws.Rows(CurrentRow + 1).EntireRow.Insert Shift:=xlDown
ws.Rows(CurrentRow).EntireRow.Copy ws.Rows(CurrentRow + 1)
CurrentRow = CurrentRow + 1
GoSub changeValues
LastRow = LastRow + 1
Return
changeValues:
For j = 0 To UBound(OldCols)
ws.Cells(CurrentRow, NewCols(j)).Value _
= ws.Cells(CurrentRow, OldCols(j)).Value
Next j
GoSub deleteValues
Return
deleteValues:
For j = 0 To UBound(OldCols)
ws.Cells(CurrentRow, OldCols(j)).ClearContents
Next j
Return
End Sub
I am trying to program a Search button to look through all the data, return all rows with the common Number and all the date which is 9 columns of data, then populate and print the sheet with this data. the code is continuously giving me errors, any help is appreciated.
Dim erow As Long
Dim ws As Worksheet
Dim Lastrow As Long
Dim count As Integer
With Worksheets("DataSheet")
Lastrow = .Cells(.Rows.count, 1).End(x1Up).Row
For x = 1 To Lastrow
If Sheets("DataSheet").Cells(x, 1) = SearchSheet.Range("B4") Then
SearchSheet.Range("A12") = Sheets("DataSheet").Cells(x, 1)
SearchSheet.Range("B12") = Sheets("DataSheet").Cells(x, 2)
SearchSheet.Range("C12") = Sheets("DataSheet").Cells(x, 3)
SearchSheet.Range("D12") = Sheets("DataSheet").Cells(x, 4)
SearchSheet.Range("E12") = Sheets("DataSheet").Cells(x, 5)
SearchSheet.Range("F12") = Sheets("DataSheet").Cells(x, 6)
SearchSheet.Range("G12") = Sheets("DataSheet").Cells(x, 7)
SearchSheet.Range("H12") = Sheets("DataSheet").Cells(x, 8)
SearchSheet.Range("I12") = Sheets("DataSheet").Cells(x, 9)
End If
Next x
End With
Hard to see the difference between one and L but x1Up should be xlUp. All the results are being written to the same row 12, you need to use an incrementing counter.
Private Sub CommandButton1_Click()
Const SEARCH_CELL = "B4"
Const START_ROW = 12
Dim wb As Workbook, wsSource As Worksheet, wsTarget As Worksheet
Set wb = ThisWorkbook
Set wsSource = wb.Sheets("DataSheet")
Set wsTarget = wb.Sheets("SearchSheet")
Dim iRow As Long, iLastRow As Long, iTargetRow As Long
Dim sSearchTerm As String, res As Variant
iTargetRow = START_ROW
sSearchTerm = wsTarget.Range(SEARCH_CELL)
' clear results sheet
wsTarget.Range("A" & START_ROW & ":I" & Rows.count).Cells.Clear
'search
With wsSource
iLastRow = .Cells(.Rows.count, 1).End(xlUp).Row
For iRow = 1 To iLastRow
If .Cells(iRow, 1) = sSearchTerm Then
.Range("A" & iRow).Resize(1, 9).Copy wsTarget.Range("A" & iTargetRow)
iTargetRow = iTargetRow + 1
End If
Next
End With
' results
With wsTarget
.PageSetup.PrintArea = .Range("A1").Resize(iTargetRow - 1, 9).Address
res = MsgBox(iTargetRow - START_ROW & " Rows found, do you want to print results ?", vbYesNo, "Finished")
If res = vbYes Then
' print
.PrintOut Copies:=1
End If
End With
End Sub
I'm trying to compare cells in 2 tabs (master and test) and if there are changes in test then color changes in any kind of color and copy & paste it to master file.
UPDATED:
Here is required code
Sub test()
Dim varSheetA As Variant
Dim varSheetB As Variant
Dim strRangeToCheck As String
Dim iRow As Long
Dim iCol As Long
Dim jRow As Long
Dim jCol As Long
strRangeToCheck = "A1:V1000"
' If you know the data will only be in a smaller range, reduce the size of the ranges above.
Debug.Print Now
varSheetA = Worksheets("Sheet1").Range(strRangeToCheck)
varSheetB = Worksheets("Sheet2").Range(strRangeToCheck) ' or whatever your other sheet is.
Debug.Print Now
For iRow = LBound(varSheetA, 1) To UBound(varSheetA, 1)
For iCol = LBound(varSheetA, 2) To UBound(varSheetA, 2)
If varSheetB(iRow, iCol) = varSheetA(iRow, iCol) Then
' Cells are identical.
' Do nothing.
Else
Sheets("Sheet1").Select
Cells(iRow, iCol).Interior.ColorIndex = 44
Sheets("Sheet2").Select
Cells(iRow, iCol).Interior.ColorIndex = 44
Sheets("Sheet2").Select
Cells(iRow, iCol).Copy
Sheets("Sheet1").Select
Cells(iRow, iCol).PasteSpecial xlValues
Cells(iRow, iCol).PasteSpecial xlFormats
' Cells are different.
' Code goes here for whatever it is you want to do.
End If
Next iCol
Next iRow
MsgBox ("Done")
End Sub
Find the last used cell in one of the worksheets.
dim lr as long, lc as long
lr= application.max(dWS.cells.specialcells(xlCellTypeLastCell).row, _
mWS.cells.specialcells(xlCellTypeLastCell).row)
lc= application.max(dWS.cells.specialcells(xlCellTypeLastCell).Column, _
mWS.cells.specialcells(xlCellTypeLastCell).Column)
For Each c In dWS.Range("A2", dWS.cells(lr, lc))
If Not dWS.Cells(c.Row, c.Column).Value = mWS.Cells(c.Row, c.Column).Value Then
dWS.Cells(c.Row, c.Column).Interior.Color = vbYellow
End If
Next