Looking for Excel VBA solution to compare data - vba

Question

Need to compare data in two excel files by FacilityID column. Excel A data has to be aggregated first. In Excel B, FacilityID is unique row.
Tries VLOOKUP. It's getting too confusing. Need VBA solution

Answer 1

Function BrowseWin(mypath As String)
With Application.FileDialog(msoFileDialogOpen)
.InitialFileName = GetDir(mypath)
If .Show = -1 Then
BrowseWin = .SelectedItems.Item(1)
Else
BrowseWin = "-"
End If
End With
End Function
Function BrowseMac(mypath As String) As String
sMacScript = "set applescript's text item delimiters to "","" " & vbNewLine & _
"try " & vbNewLine & _
"set theFiles to (choose file " & _
"with prompt ""Please select a file or files"" default location alias """ & _
mypath & """ multiple selections allowed true) as string" & vbNewLine & _
"set applescript's text item delimiters to """" " & vbNewLine & _
"on error errStr number errorNumber" & vbNewLine & _
"return errorNumber " & vbNewLine & _
"end try " & vbNewLine & _
"return theFiles"
BrowseMac = MacScript(sMacScript)
End Function
Function grantFileAccess(filePermissionCandidates)
grantFileAccess = GrantAccessToMultipleFiles(filePermissionCandidates)
End Function
Public Function GetDir(File) As String
If Application.OperatingSystem Like "*Mac*" Then
div = ":"
Else
div = "\"
End If
x = InStrRev(File, div)
If x = 0 Then
GetDir = File
Else
GetDir = Left(File, x)
End If
End Function
Sub ChooseOptima_Click()
Dim startDir As String
startDir = GetDir("/")
If Application.OperatingSystem Like "*Mac*" Then
Path = BrowseMac(startDir)
If Path = "-43" Or Path = "-1700" Then
startDir = MacScript("return (path to documents folder) as String")
Path = BrowseMac(startDir)
End If
Else
Path = BrowseWin(startDir)
End If
If Left(Path, 1) <> "-" Then
Range("Optimafile") = Path
Range("C6").Select
End If
End Sub
Sub ChooseCRC_Click()
Dim startDir As String
startDir = GetDir("/")
If Application.OperatingSystem Like "*Mac*" Then
Path = BrowseMac(startDir)
If Path = "-43" Or Path = "-1700" Then
startDir = MacScript("return (path to documents folder) as String")
Path = BrowseMac(startDir)
End If
Else
Path = BrowseWin(startDir)
End If
If Left(Path, 1) <> "-" Then
Range("Crcfile") = Path
Range("A9").Select
End If
End Sub
Sub LoadReports()
Application.ScreenUpdating = False
With Worksheets("Sheet1")
ResultPath = Range("Optimafile").Value
grantAccessReq = Application.OperatingSystem Like "*Mac*"
If grantAccessReq Then
filePermissionCandidates = Array(NormPath, ExprPath)
grantFileAccess (filePermissionCandidates)
End If
CopyToReport (ResultPath)
End With
End Sub
Sub CopyToReport(OptimaPath As String)
Dim Sheet1, Sheet2 As Worksheet
Dim CrcPath, File1, File2 As String
File1 = Right$(OptimaPath, Len(OptimaPath) - InStrRev(OptimaPath, "\"))
CrcPath = Range("CrcFile").Value
File2 = Right$(CrcPath, Len(CrcPath) - InStrRev(CrcPath, "\"))
Application.DisplayAlerts = False
For Each ws In Worksheets
If ws.Name = "Optima Blue" Then
Sheets("Optima Blue").Delete
End If
Next
For Each ws In Worksheets
If ws.Name = "Optima Green" Then
Sheets("Optima Green").Delete
End If
Next
For Each ws In Worksheets
If ws.Name = "CRC Limit" Then
Sheets("CRC Limit").Delete
End If
Next
For Each ws In Worksheets
If ws.Name = "CRC Usage" Then
Sheets("CRC Usage").Delete
End If
Next
For Each ws In Worksheets
If ws.Name = "Result Limit" Then
Sheets("Result Limit").Delete
End If
Next
For Each ws In Worksheets
If ws.Name = "Result Usage" Then
Sheets("Result Usage").Delete
End If
Next
For Each ws In Worksheets
If ws.Name = "CRC Usage Consolidated" Then
Sheets("CRC Usage Consolidated").Delete
End If
Next
For Each ws In Worksheets
If ws.Name = "CRC Limit Consolidated" Then
Sheets("CRC Limit Consolidated").Delete
End If
Next
Application.DisplayAlerts = True
Workbooks.Open (OptimaPath)
Set Sheet1 = Workbooks(File1).Worksheets(1)
MakeOptimaBlueSheet
MakeOptimaGreenSheet
CloseBook (File1)
Workbooks.Open (CrcPath)
Set Sheet2 = Workbooks(File2).Worksheets("CRC")
MakeCRCSheetLimit
MakeCRCSheetUsage
CloseBook (File2)
MakeCRCSheetUsageConsolidated
MakeCRCSheetLimitConsolidated
MakeResultOptimaBlue
MakeResultOptimaGreen
MakeResultLimitReport
MakeResultUsageReport
End Sub
Sub MakeOptimaBlueSheet()
dlastRow = ActiveSheet.Cells(Rows.Count, "I").End(xlUp).Row
Dim rng, aRng, bRng As Range
Dim i, a, hSearch, head, headerCount As Integer
Set FirstCellExclude = ThisWorkbook.Sheets("Sheet1").Range("FirstCellExcludeHeader")
Set SecondCellExclude = ThisWorkbook.Sheets("Sheet1").Range("SecondCellExcludeHeader")
Set OptimaBlueHeaders = ThisWorkbook.Sheets("Sheet1").Range("OptimaBlueHeaders")
Set FindHeaders = ActiveSheet.Range("A1:ZZ1")
Set u = Union(FirstCellExclude, OptimaBlueHeaders, SecondCellExclude)
For Each fcell In FindHeaders
For Each oCell In u
If IsEmpty(fcell) Or IsEmpty(oCell) Then
ElseIf fcell = oCell Then
If Not IsEmpty(strRange) Then strRange = strRange + ","
Cell_Add = Split(fcell.Address, "$")
strRange = strRange + Cell_Add(1) + "1:" + Cell_Add(1) + CStr(dlastRow)
headerCount = headerCount + 1
Else
End If
Next oCell
Next fcell
ActiveSheet.Range(strRange).Select
Selection.Copy
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = "Optima Blue"
ws.Paste
Set ws2 = ThisWorkbook.Sheets("Sheet1")
Set ExcludeRng = ws2.Range("FirstCellValues")
exclLastRow = ws2.Range("FirstCellValues").Rows.Count
Set searchFilterLetter = ws.Range("A1:Z1")
For Each gcell In searchFilterLetter
If IsEmpty(gcell) Then
ElseIf gcell = FirstCellExclude.Value Then
Cell_Add = Split(gcell.Address, "$")
FilterLetter = Cell_Add(1)
Debug.Print FilterLetter
Else
End If
Next gcell
For i = ws.Range(FilterLetter + "2:" & FilterLetter & dlastRow & " ").Cells.Count To 1 Step -1
For a = exclLastRow To 1 Step -1
If IsEmpty(ws.Cells(i, FilterLetter)) Or IsEmpty(ExcludeRng.Cells(a, 1)) Then
ElseIf ws.Cells(i, FilterLetter) = ExcludeRng.Cells(a, 1) Then
ws.Cells(i, FilterLetter).EntireRow.Delete
Else
End If
Next a
Next i
ws.Range(FilterLetter + "1:" & FilterLetter & dlastRow & " ").Delete
Set searchFilterLetter = ws.Range("A1:Z1")
For Each gcell In searchFilterLetter
If IsEmpty(gcell) Then
ElseIf gcell = SecondCellExclude.Value Then
Cell_Add = Split(gcell.Address, "$")
FilterLetter = Cell_Add(1)
Debug.Print FilterLetter
Else
End If
Next gcell
Set ExcludeRng2 = ws2.Range("SecondCellValues")
exclLastRow2 = ws2.Range("SecondCellValues").Rows.Count
For i = ws.Range(FilterLetter + "2:" & FilterLetter & dlastRow & " ").Cells.Count To 1 Step -1
For a = exclLastRow2 To 1 Step -1
If IsEmpty(ws.Cells(i, FilterLetter)) Or IsEmpty(ExcludeRng2.Cells(a, 1)) Then
ElseIf ws.Cells(i, FilterLetter) = ExcludeRng2.Cells(a, 1) Then
ws.Cells(i, FilterLetter).EntireRow.Delete
Else
End If
Next a
Next i
ws.Range(FilterLetter + "1:" & FilterLetter & dlastRow & " ").Delete
ws.Range("G1") = "Optima Blue Total"
ws.Range("G2").Formula = "=B2+C2+D2+E2+F2"
ws.Range("G2").Copy
ws.Range("G3:G" & dlastRow & " ").PasteSpecial (xlPasteAll)
ws.Range("G2:G" & dlastRow & " ").NumberFormat = "#,##0"
For Each rng In ws.Range("G2:G" & dlastRow & " ")
If rng.HasFormula Then
rng.Formula = rng.Value
End If
Next rng
ws.Range("B:F").Delete
End With
End Sub
Sub MakeOptimaGreenSheet()
dlastRow = ActiveSheet.Cells(Rows.Count, "I").End(xlUp).Row
Dim rng As Range
Dim i, a, hSearch, head, headerCount As Integer
Set FirstCellExclude = ThisWorkbook.Sheets("Sheet1").Range("FirstCellExcludeHeader")
Set SecondCellExclude = ThisWorkbook.Sheets("Sheet1").Range("SecondCellExcludeHeader")
Set OptimaGreenHeaders = ThisWorkbook.Sheets("Sheet1").Range("OptimaGreenHeaders")
Set FindHeaders = ActiveSheet.Range("A1:ZZ1")
Set u = Union(FirstCellExclude, SecondCellExclude, OptimaGreenHeaders)
For Each fcell In FindHeaders
For Each oCell In u
If IsEmpty(fcell) Or IsEmpty(oCell) Then
ElseIf fcell = oCell Then
If Not IsEmpty(strRange) Then strRange = strRange + ","
Cell_Add = Split(fcell.Address, "$")
strRange = strRange + Cell_Add(1) + "1:" + Cell_Add(1) + CStr(dlastRow)
headerCount = headerCount + 1
Else
End If
Next oCell
Next fcell
ActiveSheet.Range(strRange).Select
Selection.Copy
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = "Optima Green"
ws.Paste
Set ws2 = ThisWorkbook.Sheets("Sheet1")
Set ExcludeRng = ws2.Range("FirstCellValues")
exclLastRow = ws2.Range("FirstCellValues").Rows.Count
Set searchFilterLetter = ws.Range("A1:Z1")
For Each gcell In searchFilterLetter
If IsEmpty(gcell) Then
ElseIf gcell = FirstCellExclude.Value Then
Cell_Add = Split(gcell.Address, "$")
FilterLetter = Cell_Add(1)
Debug.Print FilterLetter
Else
End If
Next gcell
For i = ws.Range(FilterLetter + "2:" & FilterLetter & dlastRow & " ").Cells.Count To 1 Step -1
For a = exclLastRow To 1 Step -1
If IsEmpty(ws.Cells(i, FilterLetter)) Or IsEmpty(ExcludeRng.Cells(a, 1)) Then
ElseIf ws.Cells(i, FilterLetter) = ExcludeRng.Cells(a, 1) Then
ws.Cells(i, FilterLetter).EntireRow.Delete
Else
End If
Next a
Next i
ws.Range(FilterLetter + "1:" & FilterLetter & dlastRow & " ").Delete
Set searchFilterLetter = ws.Range("A1:Z1")
For Each gcell In searchFilterLetter
If IsEmpty(gcell) Then
ElseIf gcell = SecondCellExclude.Value Then
Cell_Add = Split(gcell.Address, "$")
FilterLetter = Cell_Add(1)
Debug.Print FilterLetter
Else
End If
Next gcell
Set ExcludeRng2 = ws2.Range("SecondCellValues")
exclLastRow2 = ws2.Range("SecondCellValues").Rows.Count
For i = ws.Range(FilterLetter + "2:" & FilterLetter & dlastRow & " ").Cells.Count To 1 Step -1
For a = exclLastRow2 To 1 Step -1
If IsEmpty(ws.Cells(i, FilterLetter)) Or IsEmpty(ExcludeRng2.Cells(a, 1)) Then
ElseIf ws.Cells(i, FilterLetter) = ExcludeRng2.Cells(a, 1) Then
ws.Cells(i, FilterLetter).EntireRow.Delete
Else
End If
Next a
Next i
ws.Range(FilterLetter + "1:" & FilterLetter & dlastRow & " ").Delete
ws.Range("G1") = "Optima Green Total"
ws.Range("G2").Formula = "=B2+C2+D2+E2+F2"
ws.Range("G2").Copy
ws.Range("G3:G" & dlastRow & " ").PasteSpecial (xlPasteAll)
ws.Range("G2:G" & dlastRow & " ").NumberFormat = "#,##0"
For Each rng In ws.Range("G2:G" & dlastRow & " ")
If rng.HasFormula Then
rng.Formula = rng.Value
End If
Next rng
ws.Range("B:F").Delete
End With
End Sub
Sub MakeCRCSheetLimit()
dlastRow = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row
Dim rng As Range
Dim i, a, hSearch, head, headerCount As Integer
Set FirstCrcFilter = ThisWorkbook.Sheets("Sheet1").Range("FirstCrcFilterHeader")
Set SecondCrcFilter = ThisWorkbook.Sheets("Sheet1").Range("SecondCrcFilterHeader")
Set CrcLimitHeaders = ThisWorkbook.Sheets("Sheet1").Range("CrcLimitHeaders")
Set FindHeaders = ActiveSheet.Range("A1:ZZ1")
Set u = Union(CrcLimitHeaders, FirstCrcFilter, SecondCrcFilter)
For Each fcell In FindHeaders
For Each oCell In u
If IsEmpty(fcell) Or IsEmpty(oCell) Then
ElseIf fcell = oCell Then
If Not IsEmpty(strRange) Then strRange = strRange + ","
Cell_Add = Split(fcell.Address, "$")
strRange = strRange + Cell_Add(1) + "1:" + Cell_Add(1) + CStr(dlastRow)
headerCount = headerCount + 1
Else
End If
Next oCell
Next fcell
ActiveSheet.Range(strRange).Select
Selection.Copy
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = "CRC Limit"
ws.Paste
Set ws2 = ThisWorkbook.Sheets("Sheet1")
Set ExcludeRng = ws2.Range("FirstCrcFilterValues")
exclLastRow = ws2.Range("FirstCrcFilterValues").Rows.Count
Set searchFilterLetter = ws.Range("A1:Zz1")
For Each gcell In searchFilterLetter
If IsEmpty(gcell) Then
ElseIf gcell = FirstCrcFilter Then
Cell_Add = Split(gcell.Address, "$")
FilterLetter = Cell_Add(1)
Else
End If
Next gcell
For i = ws.Range(FilterLetter + "2:" & FilterLetter & dlastRow & " ").Cells.Count To 1 Step -1
For a = exclLastRow To 1 Step -1
If IsEmpty(ws.Cells(i, FilterLetter)) Or IsEmpty(ExcludeRng.Cells(a, 1)) Then
ElseIf ws.Cells(i, FilterLetter) = ExcludeRng.Cells(a, 1) Then
ws.Cells(i, FilterLetter).EntireRow.Delete
Else
End If
Next a
Next i
ws.Range(FilterLetter + "1:" & FilterLetter & dlastRow & " ").Delete
Set ExcludeRng2 = ws2.Range("SecondCrcFilterValues")
exclLastRow2 = ExcludeRng2.Rows.Count
Set searchFilterLetter = ws.Range("A1:Zz1")
For Each gcell In searchFilterLetter
If IsEmpty(gcell) Then
ElseIf gcell = SecondCrcFilter Then
Cell_Add = Split(gcell.Address, "$")
FilterLetter = Cell_Add(1)
Else
End If
Next gcell
For i = ws.Range(FilterLetter + "2:" & FilterLetter & dlastRow & " ").Cells.Count To 1 Step -1
For a = exclLastRow2 To 1 Step -1
Debug.Print ws.Cells(i, FilterLetter), ExcludeRng2.Cells(a, 1)
If IsEmpty(ws.Cells(i, FilterLetter)) Or IsEmpty(ExcludeRng2.Cells(a, 1)) Then
ElseIf ws.Cells(i, FilterLetter) = ExcludeRng2.Cells(a, 1) Then
ws.Cells(i, FilterLetter).EntireRow.Delete
Else
End If
Next a
Next i
ws.Range(FilterLetter + "1:" & FilterLetter & dlastRow & " ").Delete
ws.Range("B2:B" & dlastRow & " ").NumberFormat = "#,##0"
End With
End Sub
Sub MakeCRCSheetUsage()
dlastRow = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row
Dim rng As Range
Dim i, a, hSearch, head, headerCount As Integer
Set FirstCrcFilter = ThisWorkbook.Sheets("Sheet1").Range("FirstCrcFilterHeader")
Set SecondCrcFilter = ThisWorkbook.Sheets("Sheet1").Range("SecondCrcFilterHeader")
Set CrcLimitHeaders = ThisWorkbook.Sheets("Sheet1").Range("CrcUsageHeaders")
Set FindHeaders = ActiveSheet.Range("A1:ZZ1")
Set u = Union(CrcLimitHeaders, FirstCrcFilter, SecondCrcFilter)
For Each fcell In FindHeaders
For Each oCell In u
If IsEmpty(fcell) Or IsEmpty(oCell) Then
ElseIf fcell = oCell Then
If Not IsEmpty(strRange) Then strRange = strRange + ","
Cell_Add = Split(fcell.Address, "$")
strRange = strRange + Cell_Add(1) + "1:" + Cell_Add(1) + CStr(dlastRow)
headerCount = headerCount + 1
Else
End If
Next oCell
Next fcell
ActiveSheet.Range(strRange).Select
Selection.Copy
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = "CRC Usage"
ws.Paste
Set ws2 = ThisWorkbook.Sheets("Sheet1")
Set ExcludeRng = ws2.Range("FirstCrcFilterValues")
exclLastRow = ws2.Range("FirstCrcFilterValues").Rows.Count
Set searchFilterLetter = ws.Range("A1:Zz1")
For Each gcell In searchFilterLetter
If IsEmpty(gcell) Then
ElseIf gcell = FirstCrcFilter Then
Cell_Add = Split(gcell.Address, "$")
FilterLetter = Cell_Add(1)
Else
End If
Next gcell
For i = ws.Range(FilterLetter + "2:" & FilterLetter & dlastRow & " ").Cells.Count To 1 Step -1
For a = exclLastRow To 1 Step -1
If IsEmpty(ws.Cells(i, FilterLetter)) Or IsEmpty(ExcludeRng.Cells(a, 1)) Then
ElseIf ws.Cells(i, FilterLetter) = ExcludeRng.Cells(a, 1) Then
ws.Cells(i, FilterLetter).EntireRow.Delete
Else
End If
Next a
Next i
ws.Range(FilterLetter + "1:" & FilterLetter & dlastRow & " ").Delete
Set ExcludeRng2 = ws2.Range("SecondCrcFilterValues")
exclLastRow2 = ExcludeRng2.Rows.Count
Set searchFilterLetter = ws.Range("A1:Zz1")
For Each gcell In searchFilterLetter
If IsEmpty(gcell) Then
ElseIf gcell = SecondCrcFilter Then
Cell_Add = Split(gcell.Address, "$")
FilterLetter = Cell_Add(1)
Else
End If
Next gcell
For i = ws.Range(FilterLetter + "2:" & FilterLetter & dlastRow & " ").Cells.Count To 1 Step -1
For a = exclLastRow2 To 1 Step -1
If IsEmpty(ws.Cells(i, FilterLetter)) Or IsEmpty(ExcludeRng2.Cells(a, 1)) Then
ElseIf ws.Cells(i, FilterLetter) = ExcludeRng2.Cells(a, 1) Then
ws.Cells(i, FilterLetter).EntireRow.Delete
Else
End If
Next a
Next i
ws.Range(FilterLetter + "1:" & FilterLetter & dlastRow & " ").Delete
ws.Range("B2:B" & dlastRow & " ").NumberFormat = "#,##0"
End With
End Sub
Sub MakeCRCSheetUsageConsolidated()
Dim CRCSheetUsageConsolidated As Worksheet, Result As Worksheet
Dim ConsolidateRangeArray As Variant
Set CRCSheetUsageConsolidated = Sheets("CRC Usage")
CRCSheetUsageConsolidated.Select
dlastRow = CRCSheetUsageConsolidated.Cells(Rows.Count, "A").End(xlUp).Row
CRCSheetUsageConsolidated.Select
CRCSheetUsageConsolidated.Range("A1:A" & dlastRow & " ").Select
Selection.Copy
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = "CRC Usage Consolidated"
Selection.Consolidate Sources:= _
"'CRC Usage'!R1C1:R" & dlastRow & "C2", Function:= _
xlSum, TopRow:=True, LeftColumn:=True, CreateLinks:=False
End With
End Sub
Sub MakeCRCSheetLimitConsolidated()
Dim CRCSheetLimitConsolidated As Worksheet, Result As Worksheet
Dim ConsolidateRangeArray As Variant
Set CRCSheetLimitConsolidated = Sheets("CRC Limit")
CRCSheetLimitConsolidated.Select
dlastRow = CRCSheetLimitConsolidated.Cells(Rows.Count, "A").End(xlUp).Row
CRCSheetLimitConsolidated.Select
CRCSheetLimitConsolidated.Range("A1:A" & dlastRow & " ").Select
Selection.Copy
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = "CRC Limit Consolidated"
Selection.Consolidate Sources:= _
"'CRC Limit'!R1C1:R" & dlastRow & "C2", Function:= _
xlSum, TopRow:=True, LeftColumn:=True, CreateLinks:=False
End With
End Sub
Sub MakeResultOptimaBlue()
Dim OptimaBlue As Worksheet, Result As Worksheet
Dim ConsolidateRangeArray As Variant
Set OptimaBlue = Sheets("Optima Blue")
OptimaBlue.Select
dlastRow = OptimaBlue.Cells(Rows.Count, "A").End(xlUp).Row
OptimaBlue.Range("A1:A" & dlastRow & " ").Select
Selection.Copy
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = "Result Limit"
Selection.Consolidate Sources:= _
"'Optima Blue'!R1C1:R" & dlastRow & "C2", Function:= _
xlSum, TopRow:=True, LeftColumn:=True, CreateLinks:=False
End With
End Sub
Sub MakeResultOptimaGreen()
Dim OptimaGreen As Worksheet, Result As Worksheet
Dim ConsolidateRangeArray As Variant
Set OptimaGreen = Sheets("Optima Green")
OptimaGreen.Select
dlastRow = OptimaGreen.Cells(Rows.Count, "A").End(xlUp).Row
OptimaGreen.Range("A1:A" & dlastRow & " ").Select
Selection.Copy
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = "Result Usage"
Selection.Consolidate Sources:= _
"'Optima Green'!R1C1:R" & dlastRow & "C2", Function:= _
xlSum, TopRow:=True, LeftColumn:=True, CreateLinks:=False
End With
End Sub
Sub MakeResultLimitReport()
Dim shOptima As Worksheet, shCrc As Worksheet, shResult As Worksheet
Dim aRng, bRng As Range
Dim Fnd As Range
Dim ListObject As ListObject
Set shOptima = Sheets("Optima Blue")
Set shCrc = Sheets("CRC Limit Consolidated")
Set shResult = Sheets("Result Limit")
bLastRow = shResult.Cells(Rows.Count, "A").End(xlUp).Row
aLastRow = shCrc.Cells(Rows.Count, "A").End(xlUp).Row
Set aRng = shCrc.Range("A2:A" & aLastRow & "") '127
Set bRng = shResult.Range("A2:A" & bLastRow & "") '71
For Each aCell In aRng
For Each bcell In bRng
If aCell Is Nothing Or bcell Is Nothing Then
ElseIf aCell.Text = bcell.Text Then
bcell.Offset(0, 2).Formula = "='CRC Limit Consolidated'!" & aCell.Offset(0, 1).Address & " "
Else
End If
Next bcell
Next aCell
shResult.Range("D2").Formula = "=IF(B2=0,IF(C2=0,0,abs(((B2-C2)/C2)*100)),abs(((C2-B2)/B2)*100))"
shResult.Range("D2").Copy
shResult.Range("D3:D" & bLastRow).PasteSpecial (xlPasteAll)
shResult.Range("D2:D" & bLastRow).NumberFormat = "#,##0"
shResult.Range("D2:D" & bLastRow).NumberFormat = "#,##0.00"
shResult.Activate
shResult.Range("A1") = "Facility ID"
shResult.Range("D1") = "Diff in percent"
shResult.Range("C1") = "CRC Limit"
shResult.Range("B2:D" & bLastRow & " ").NumberFormat = "#,##0"
shOptima.Range("E1:g1").Interior.ColorIndex = 35
Range("A1:G" & bLastRow).EntireColumn.AutoFit
Range("A2:D" & bLastRow).Sort key1:=Range("D2:D" & bLastRow), order1:=xlDescending, Header:=xlNo
Set ListObject = ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes)
With ListObject
.Name = "Table4"
.TableStyle = "TableStyleMedium5"
End With
End Sub
Sub MakeResultUsageReport()
Dim shOptima As Worksheet, shCrc As Worksheet, shResult As Worksheet
Dim aRng, bRng As Range
Dim Fnd As Range
Dim ListObject As ListObject
Set shOptima = Sheets("Optima Green")
Set shCrc = Sheets("CRC Usage Consolidated")
Set shResult = Sheets("Result Usage")
bLastRow = shResult.Cells(Rows.Count, "A").End(xlUp).Row
aLastRow = shCrc.Cells(Rows.Count, "A").End(xlUp).Row
Set aRng = shCrc.Range("A2:A" & aLastRow & "")
Set bRng = shResult.Range("A2:A" & bLastRow & "")
For Each aCell In aRng
For Each bcell In bRng
If aCell Is Nothing Or bcell Is Nothing Then
ElseIf aCell.Text = bcell.Text Then
bcell.Offset(0, 2).Formula = "='CRC Usage Consolidated'!" & aCell.Offset(0, 1).Address & " "
Else
End If
Next bcell
Next aCell
shResult.Range("D2").Formula = "=IF(B2=0,IF(C2=0,0,abs(((B2-C2)/C2)*100)),abs(((C2-B2)/B2)*100))"
shResult.Range("D2").Copy
shResult.Range("D3:D" & bLastRow).PasteSpecial (xlPasteAll)
shResult.Range("D2:D" & bLastRow).NumberFormat = "#,##0"
shResult.Range("D2:D" & bLastRow).NumberFormat = "#,##0.00"
shResult.Activate
shResult.Range("A1") = "Facility ID"
shResult.Range("D1") = "Diff in percent"
shResult.Range("C1") = "CRC Usage"
shResult.Range("B2:D" & bLastRow & " ").NumberFormat = "#,##0"
shOptima.Range("E1:g1").Interior.ColorIndex = 35
Range("A1:G" & bLastRow).EntireColumn.AutoFit
Range("A2:D" & bLastRow).Sort key1:=Range("D2:D" & bLastRow), order1:=xlDescending, Header:=xlNo
Set ListObject = ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes)
With ListObject
.Name = "Table4"
.TableStyle = "TableStyleMedium4"
End With
Application.ScreenUpdating = True
End Sub
Sub CloseBook(File As String)
Workbooks(File).Close savechanges:=False
End Sub