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
Related
I am having issued with this code, the loop is supposed to only run once but its running 6 times and passing all of the data even though the toggle buttons are not pressed
the way this is supposed to work is that only the data that has the toggle button attached to it will be transferred to column C and E. its working but, its passing all the data and more even if the toggle buttons are not pressed
Private Sub SubmitCSR_Click()
Dim LastRow As Long
Dim ws As Worksheet: Set ws = Sheets("GP count")
Dim StockCaption(1 To 6) As String
'populate the array
StockCaption(1) = ToggleButton6.Caption
StockCaption(2) = ToggleButton2.Caption
StockCaption(3) = ToggleButton4.Caption
StockCaption(4) = ToggleButton5.Caption
StockCaption(5) = ToggleButton1.Caption
StockCaption(6) = ToggleButton3.Caption
'declare a variant to hold the array element
Dim StockCC As Variant
Dim ReceivedV(1 To 6) As String
'populate the array
ReceivedV(1) = R1.Value
ReceivedV(2) = R2.Value
ReceivedV(3) = R3.Value
ReceivedV(4) = R4.Value
ReceivedV(5) = R5.Value
ReceivedV(6) = R6.Value
'declare a variant to hold the array element
Dim ReceivingN As Variant
'loop through the entire array
Dim strNames(1 To 6) As Variant
'populate the array
strNames(1) = ToggleButton6.Value
strNames(2) = ToggleButton2.Value
strNames(3) = ToggleButton4.Value
strNames(4) = ToggleButton5.Value
strNames(5) = ToggleButton1.Value
strNames(6) = ToggleButton3.Value
'declare a variant to hold the array element
Dim StockValue As Variant
'loop through the entire array
For Each StockValue In strNames
For Each ReceivingN In ReceivedV
For Each StockCC In StockCaption
If StockValue = True Then
LastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
ws.Range("C" & LastRow + 1).Value = StockCC
LastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row
ws.Range("E" & LastRow + 1).Value = ReceivingN
End If
Next StockCC
Next ReceivingN
Next StockValue
End Sub
You probably only want 1 standard for loop:
Private Sub SubmitCSR_Click()
Dim LastRow As Long
Dim ws As Worksheet: Set ws = Sheets("GP count")
Dim StockCaption(1 To 6) As String
'populate the array
StockCaption(1) = ToggleButton6.Caption
StockCaption(2) = ToggleButton2.Caption
StockCaption(3) = ToggleButton4.Caption
StockCaption(4) = ToggleButton5.Caption
StockCaption(5) = ToggleButton1.Caption
StockCaption(6) = ToggleButton3.Caption
Dim ReceivedV(1 To 6) As String
'populate the array
ReceivedV(1) = R1.Value
ReceivedV(2) = R2.Value
ReceivedV(3) = R3.Value
ReceivedV(4) = R4.Value
ReceivedV(5) = R5.Value
ReceivedV(6) = R6.Value
'loop through the entire array
Dim strNames(1 To 6) As Variant
'populate the array
strNames(1) = ToggleButton6.Value
strNames(2) = ToggleButton2.Value
strNames(3) = ToggleButton4.Value
strNames(4) = ToggleButton5.Value
strNames(5) = ToggleButton1.Value
strNames(6) = ToggleButton3.Value
'declare a variant to hold the array element
Dim i As Long
For i = 1 To 6
If StockCaption(i) = True Then
LastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
ws.Range("C" & LastRow + 1).Value = strNames(i)
LastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row
ws.Range("E" & LastRow + 1).Value = ReceivedV(i)
End If
Next i
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 run through a column and get the value in the cell. The value is a unique code and only appears once on the first sheet.
When i get a value, it could be the first cell, i want to go through a column in sheet 4. The unique code can appear multiple times on sheet 4.
I want to match the code from sheet one with the code from sheet 4. If the codes are matching, i want to save the colum value on the row index and insert it into a completely new workbook.
Sub exportSheet2()
Const START_ROW = 11
Const MAX_ROW = 40
Const CODE_SHT1 = "C"
Const CODE_SHT4 = "E"
Const CVR_SHT4 = "C"
Const CVR_SHT3 = "C"
Const WB_OUTPUT = "MyResult.xlsx"
' sheet 4 columns
'C - Employer CVR MD
'D - Employer name
'E - broker code
'F - Broker name
'? Employer CVR CER
Dim wb As Workbook, wbNew As Workbook
Dim ws1 As Worksheet, ws4 As Worksheet, wsNew As Worksheet
Dim iRow As Long, iLastRow, iTargetRow As Long, iCopyRow As Long
Dim msg As String, i As Integer
Dim count As Long, countWB As Integer
Dim WkSht_Src As Worksheet
Dim WkBk_Dest As Workbook
Dim WkSht_Dest As Worksheet
Dim Rng As Range
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("BrokerSelect")
Set ws3 = wb.Sheets("ContributionExceptionReport")
Set ws4 = wb.Sheets("MasterData")
Dim dict As Object, sKey As String, ar As Variant
Set dict = CreateObject("Scripting.Dictionary")
' build dictionary from sheet4 of code to rows number
iLastRow = ws4.Cells(Rows.count, CODE_SHT4).End(xlUp).Row
For iRow = 13 To iLastRow
sKey = ws4.Cells(iRow, CODE_SHT4)
If dict.exists(sKey) Then
dict(sKey) = dict(sKey) & ";" & iRow ' matched row on sheet 1
Else
dict(sKey) = iRow
End If
Next
' scan down sheet1
count = 0: countWB = 0
iRow = START_ROW
Do Until (ws1.Cells(iRow, CODE_SHT1) = "END") Or (iRow > MAX_ROW)
sKey = ws1.Cells(iRow, CODE_SHT1)
If dict.exists(sKey) Then
' rows on sheet4 to copy
ar = Split(dict(sKey), ";")
'create new workbook and copy rows
Dim Pheight As Integer
Pheight = 25000
Set WkSht_Src = ThisWorkbook.Worksheets(2)
Set Rng = WkSht_Src.Range(ThisWorkbook.Worksheets(2).Cells(1, 1), ThisWorkbook.Worksheets(2).Cells(Pheight, 48))
Set WkBk_Dest = Application.Workbooks.Add
Set WkSht_Dest = WkBk_Dest.Worksheets(1)
Rng.Copy
WkSht_Dest.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
Rng.Copy
WkSht_Dest.Range("A1").PasteSpecial xlPasteFormats
WkSht_Src.Pictures(1).Copy
WkSht_Dest.Range("A1").PasteSpecial
WkSht_Dest.Pictures(1).Top = 5
WkSht_Dest.Pictures(1).Left = 0
iTargetRow = 11
Set wsNew = WkSht_Dest
Set wbNew = WkBk_Dest
For i = LBound(ar) To UBound(ar)
iCopyRow = ar(i)
iTargetRow = iTargetRow + 1
' copy selected cols to new workbook
ws4.Range("C" & iCopyRow).Resize(1, 5).Copy wsNew.Range("A" & iTargetRow)
count = count + 1
Next
wbNew.SaveAs sKey & ".xlsx"
wbNew.Close
countWB = countWB + 1
End If
iRow = iRow + 1
Loop
MsgBox dict.count & " keys in dictionary ", vbInformation
msg = iLastRow & " rows scanned on sheet4 " & vbCr & _
count & " rows copied to " & countWB & " new workbooks"
MsgBox msg, vbInformation
End Sub '''
Use a Dictionary Object not a loop in a loop.
Sub exportSheet2()
Const START_ROW = 11
Const MAX_ROW = 40
Const CODE_SHT1 = "C"
Const CODE_SHT4 = "E"
Const CVR_SHT4 = "C"
Const CVR_SHT3 = "C"
' sheet 4 columns
'C - Employer CVR MD
'D - Employer name
'E - broker code
'F - Broker name
'? Employer CVR CER
Dim wb As Workbook, wbNew As Workbook
Dim ws1 As Worksheet, ws3 As Worksheet, ws4 As Worksheet, wsNew As Worksheet
Dim iRow As Long, iLastRow, iTargetRow As Long, iCopyRow As Long
Dim msg As String, i As Integer, j As Integer
Dim count As Long, countWB As Integer
Dim WkSht_Src As Worksheet
Dim WkBk_Dest As Workbook
Dim WkSht_Dest As Worksheet
Dim Rng As Range
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("BrokerSelect")
Set ws3 = wb.Sheets("ContributionExceptionReport")
Set ws4 = wb.Sheets("MasterData")
Dim dict As Object, dictCVR As Object, sKey As String, ar As Variant
Dim sCVR As String, arCVR As Variant
Set dict = CreateObject("Scripting.Dictionary")
Set dictCVR = CreateObject("Scripting.Dictionary")
' build dictionary from sheet4 of code to rows number
iLastRow = ws4.Cells(Rows.count, CODE_SHT4).End(xlUp).Row
For iRow = 13 To iLastRow
sKey = ws4.Cells(iRow, CODE_SHT4)
If dict.exists(sKey) Then
dict(sKey) = dict(sKey) & ";" & iRow ' matched row on sheet 1
Else
dict(sKey) = iRow
End If
Next
' build dictCVR from sheet3
iLastRow = ws3.Cells(Rows.count, CVR_SHT3).End(xlUp).Row
For iRow = 18 To iLastRow
sKey = ws3.Cells(iRow, CVR_SHT3)
If dictCVR.exists(sKey) Then
dictCVR(sKey) = dictCVR(sKey) & ";" & iRow
Else
dictCVR(sKey) = iRow
End If
Next
' scan down sheet1
count = 0: countWB = 0
iRow = START_ROW
Do Until (ws1.Cells(iRow, CODE_SHT1) = "END") Or (iRow > MAX_ROW)
sKey = ws1.Cells(iRow, CODE_SHT1)
If dict.exists(sKey) Then
' rows on sheet4 to copy
ar = Split(dict(sKey), ";")
'create new workbook and copy rows
Set WkSht_Src = wb.Worksheets(2)
Set Rng = WkSht_Src.Range("A1:AV25000")
Set WkBk_Dest = Application.Workbooks.Add
Set WkSht_Dest = WkBk_Dest.Worksheets(1)
With WkSht_Dest
Rng.Copy
.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
.Range("A1").PasteSpecial xlPasteFormats
WkSht_Src.Pictures(1).Copy
.Range("A1").PasteSpecial
.Pictures(1).Top = 5
.Pictures(1).Left = 0
End With
Application.CutCopyMode = False
iTargetRow = 11
Set wsNew = WkSht_Dest
Set wbNew = WkBk_Dest
For i = LBound(ar) To UBound(ar)
iCopyRow = ar(i)
iTargetRow = iTargetRow + 1
' copy selected cols to new workbook
ws4.Range("C" & iCopyRow).Resize(1, 5).Copy wsNew.Range("A" & iTargetRow)
' add cvr records from sheet3 it any
sCVR = ws4.Cells(iCopyRow, CVR_SHT4)
If dictCVR.exists(sCVR) Then
arCVR = Split(dictCVR(sCVR), ";")
For j = LBound(arCVR) To UBound(arCVR)
If j > 0 Then iTargetRow = iTargetRow + 1
' copy col A to P
iCopyRow = arCVR(j)
Debug.Print sCVR, j, iCopyRow
ws3.Range("A" & iCopyRow).Resize(1, 16).Copy wsNew.Range("E" & iTargetRow)
count = count + 1
Next
Else
count = count + 1
End If
Next
wbNew.SaveAs sKey & ".xlsx"
wbNew.Close
countWB = countWB + 1
End If
iRow = iRow + 1
Loop
msg = dict.count & " keys in CODE dictionary" & vbCr & _
dictCVR.count & " keys in CVR dictionary"
MsgBox msg, vbInformation
msg = iLastRow & " rows scanned on sheet4 " & vbCr & _
count & " rows copied to " & countWB & " new workbooks"
MsgBox msg, vbInformation
End Sub '''
I have written the below code but i would like the macro to repeat this process, copying the next row down in the SS21 Master Sheet until that row is blank (the end of the table).
Something like this?
Sub Run_Buysheet()
Sheets("SS21 Master Sheet").Range("A1:AH1, AJ1:AK1, AQ1").Copy Destination:=Sheets("BUYSHEET").Range("A1")
Sheets("SS21 Master Sheet").Range("A2:AH2, AJ2:AK2, AQ2").Copy Destination:=Sheets("BUYSHEET").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Dim r As Range, i As Long, ar
Set r = Worksheets("BUYSHEET").Range("AK999999").End(xlUp) 'Range needs to be column with size list
Do While r.Row > 1
ar = Split(r.Value, "|") '| is the character that separates each size
If UBound(ar) >= 0 Then r.Value = ar(0)
For i = UBound(ar) To 1 Step -1
r.EntireRow.Copy
r.Offset(1).EntireRow.Insert
r.Offset(1).Value = ar(i)
Next
Set r = r.Offset(-1)
Loop
End Sub
SS21 Master Sheet
BUYSHEET
This scans the MASTER sheet and adds rows to the bottom of the BUYSHEET
Sub runBuySheet2()
Const COL_SIZE As String = "AQ"
Dim wb As Workbook, wsSource As Worksheet, wsTarget As Worksheet
Set wb = ThisWorkbook
Dim iLastRow As Long, iTarget As Long, iRow As Long
Dim rngSource As Range, ar As Variant, i As Integer
Set wsSource = wb.Sheets("SS21 Master Sheet")
Set wsTarget = wb.Sheets("BUYSHEET")
iLastRow = wsSource.Range("A" & Rows.Count).End(xlUp).Row
iTarget = wsTarget.Range("AK" & Rows.Count).End(xlUp).Row
With wsSource
For iRow = 1 To iLastRow
Set rngSource = Intersect(.Rows(iRow).EntireRow, .Range("A:AH, AJ:AK, AQ:AQ"))
If iRow = 1 Then
rngSource.Copy wsTarget.Range("A1")
iTarget = iTarget + 1
Else
ar = Split(.Range(COL_SIZE & iRow), "|")
For i = 0 To UBound(ar)
rngSource.Copy wsTarget.Cells(iTarget, 1)
wsTarget.Range("AK" & iTarget).Value = ar(i)
iTarget = iTarget + 1
Next
End If
Next
MsgBox "Completed"
End With
End Sub
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