VBA Combine Multiple columns of data into 1 column - vba

I am still newer to VBA and have been trying everything I can think of to get this accomplished before asking for help, but cannot figure it out.
I have an excel file with multiple tabs. I am only concerned with 2 of them. I need to combine rows based off of their values not being blank from tab "Roadmap" into column B on tab "PPPP". The code I have will do that for the first set of data, but then replaces that data with the second set.
Sub Move_PPPP()
Sheets("PPPP").Select
Rows("2:1000").Select
Selection.ClearContents
Dim rowCount2 As Long, shtSrc As Worksheet
Dim shtDest As Worksheet
Dim rng2 As Range
Dim currentRow As Long
Set shtSrc = Sheets("Roadmap")
Set shtDest = Sheets("PPPP")
rowCount2 = shtSrc.Cells(Rows.Count, "C").End(xlUp).Row
Set rng2 = shtSrc.Range("C6:C" & rowCount2)
currentRow = 2
For Each cell2 In rng2.Cells
If cell2.Value <> "" Then
shtDest.Range("B" & currentRow).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 10).Text
shtDest.Range("B" & currentRow).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 11).Text
shtDest.Range("B" & currentRow).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 12).Text
currentRow = currentRow + 1
ElseIf cell2.Value = "" Then
End If
Next cell2
End Sub
I have tried to add a range for my destination sheet, but doing that is only giving me 9 rows of the last row of data from tab "Roadmap"
Sub Move_PPPP()
Sheets("PPPP").Select
Rows("2:1000").Select
Selection.ClearContents
Dim rowCount2 As Long, shtSrc As Worksheet
Dim columnCount As Long
Dim shtDest As Worksheet
Dim rng2 As Range
Dim rng As Range
Dim currentRow As Long
Set shtSrc = Sheets("Roadmap")
Set shtDest = Sheets("PPPP")
rowCount2 = shtSrc.Cells(Rows.Count, "C").End(xlUp).Row
columnCount = shtDest.Cells(Columns.Count, "B").End(xlUp).Row
Set rng2 = shtSrc.Range("C6:C" & rowCount2)
Set rng = shtDest.Range("B2:B" & columnCount & currentRow)
currentRow = 2
For Each cell2 In rng2.Cells
If cell2.Value <> "" Then
rng.Value = " " & cell2.Text & " - " & cell2.Offset(0, 10).Text
currentRow = currentRow + 1
ElseIf cell2.Value = "" Then
End If
Next cell2
End Sub
Sample Data
Roadmap Tab
Column: C D E F G H I J K L M
Headers: Project Status Open Closed Name P1 P2 P3 P4 P5 P6
Row 1: FISMA New Yes No Albert na na na na New Day Old Data
Row 2: QRD Closed No Yes Albert na na na na na Closed
Desired Outcome. Combine Column C with Column M when M <> blank, loop through entire row and put that data in column B of PPPP tab. Then combine column C with N when N <> blank and put that on PPPP tab, column B under the data from column M.
PPPP Tab
Cell B2
FISMA - New Day
Cell B4
FISMA - Old Data
QRD - Closed
SOLUTION:
Sub Move_PPPP()
Sheets("PPPP").Select
Rows("2:1000").Select
Selection.ClearContents
Dim rowCount2 As Long, shtSrc As Worksheet
Dim shtDest As Worksheet
Dim rng2 As Range
Dim currentRow As Long
Set shtSrc = Sheets("Roadmap")
Set shtDest = Sheets("PPPP")
rowCount2 = shtSrc.Cells(Rows.Count, "C").End(xlUp).Row
Set rng2 = shtSrc.Range("C6:C" & rowCount2)
currentRow = shtDest.Range("A" & Rows.Count).End(xlUp).Row
For Each cell2 In rng2.Cells
If cell2.Value2 <> "" Then
shtDest.Range("A" & currentRow).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 9).Text
currentRow = currentRow + 1
ElseIf cell2.Value = "" Then
End If
Next cell2
Set rng2 = shtSrc.Range("C6:C" & rowCount2)
currentRow = shtDest.Range("A" & Rows.Count).End(xlUp).Row + 1
For Each cell2 In rng2.Cells
If cell2.Value2 <> "" Then
shtDest.Range("A" & currentRow + 1).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 10).Text
currentRow = currentRow + 1
ElseIf cell2.Value = "" Then
End If
Next cell2
Set rng2 = shtSrc.Range("C6:C" & rowCount2)
currentRow = shtDest.Range("A" & Rows.Count).End(xlUp).Row + 1
For Each cell2 In rng2.Cells
If cell2.Value2 <> "" Then
shtDest.Range("A" & currentRow + 1).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 11).Text
currentRow = currentRow + 1
ElseIf cell2.Value = "" Then
End If
Next cell2
Set rng2 = shtSrc.Range("C6:C" & rowCount2)
currentRow = shtDest.Range("A" & Rows.Count).End(xlUp).Row + 1
For Each cell2 In rng2.Cells
If cell2.Value2 <> "" Then
shtDest.Range("A" & currentRow + 1).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 12).Text
currentRow = currentRow + 1
ElseIf cell2.Value = "" Then
End If
Next cell2
End Sub

On the first version, try this :
Sub Move_PPPP()
Sheets("PPPP").Select
Rows("2:1000").Select
Selection.ClearContents
Dim rowCount2 As Long, shtSrc As Worksheet
Dim shtDest As Worksheet
Dim rng2 As Range
Dim currentRow As Long
Set shtSrc = Sheets("Roadmap")
Set shtDest = Sheets("PPPP")
rowCount2 = shtSrc.Cells(Rows.Count, "C").End(xlUp).Row
Set rng2 = shtSrc.Range("C6:C" & rowCount2)
currentRow = shtDest.Range("B" & Rows.Count).End(xlUp).Row
For Each cell2 In rng2.Cells
If cell2.Value <> "" Then
shtDest.Range("B" & currentRow).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 10).Text
shtDest.Range("B" & currentRow + 1).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 11).Text
shtDest.Range("B" & currentRow + 2).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 12).Text
currentRow = currentRow + 1
ElseIf cell2.Value = "" Then
End If
Next cell2
Set rng2 = shtSrc.Range("D6:D" & rowCount2)
currentRow = shtDest.Range("B" & Rows.Count).End(xlUp).Row + 1
For Each cell2 In rng2.Cells
If cell2.Value <> "" Then
shtDest.Range("B" & currentRow).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 10).Text
shtDest.Range("B" & currentRow + 1).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 11).Text
shtDest.Range("B" & currentRow + 2).Value2 = " " & cell2.Text & " - " & cell2.Offset(0, 12).Text
currentRow = currentRow + 1
ElseIf cell2.Value = "" Then
End If
Next cell2
End Sub

Related

Looking for Excel VBA solution to compare data

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
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

Consolidate data and provide average of the consolidated data

I am writing a macro, which will be used to consolidate data from a range of cells. I have the table with the data that I want to consolidate in sheets("1") in Range D2:J6 and the destination location is again in sheets("1") in M2:R2 (the colums M to R but they contain headers) . I have already written a part of the code below, which applies and runs for them. However, even though it doesnt say it has an error, it just wont run correctly.. I am prividing the screenshot from my excel after the macro runs ..
as you can see from the image, I want to consolidate the duplicate values in row D and print the average of the values located in columns E,F,G, H, I ,J on the same row as the consolidated values in column D. For example for the value "Gebze 6832" in column D, I want to remove it as a duplicate, make it one cell in the destination and print the average of the columns E,F,G, H, I ,J from the two rows that were consolidated next to it in the destination columns.
My code is below (UPDATE)
Dim ws As Worksheet
Dim dataRng As Range
Dim dic As Variant, arr As Variant
Dim cnt As Long
Set ws = Sheets("1")
With ws
lastrow = .Cells(.Rows.Count, "D").End(xlUp).Row 'get last row in Column D
Set dataRng = .Range("D2:D" & lastrow) 'range for Column D
Set dic = CreateObject("Scripting.Dictionary")
arr = dataRng.Value
For i = 1 To UBound(arr)
dic(arr(i, 1)) = dic(arr(i, 1)) + 1
Next
.Range("M2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.keys) 'uniques data from Column D
.Range("Q2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.items)
cnt = dic.Count
For i = 2 To cnt + 1
.Range("N" & i & ":P" & i).Formula = "=SUMIF($D$2:$D$" & lastrow & ",$M" & i & ",E$2:E$" & lastrow & ")/" & dic(.Range("M" & i).Value)
.Range("R" & i).Formula = "=IF(INDEX($I$2:$I$" & lastrow & ",MATCH($M" & i & ",$D$2:$D$" & lastrow & ",0))=0,N" & i & ","""")"
.Range("S" & i).Formula = "=IF(INDEX($I$2:$I$" & lastrow & ",MATCH($M" & i & ",$D$2:$D$" & lastrow & ",0))=0,Q" & i & ","""")"
.Range("T" & i).Formula = "=IF($S" & i & ">0,SUMPRODUCT(($D$2:$D$" & lastrow & "=$M" & i & ")*(($J$2:$J$" & lastrow & "-$E$2:$E$" & lastrow & ")>3%)),"""")"
Next i
.Range("M" & i).Value = "Grand Total"
.Range("N" & i & ":P" & i).Formula = "=AVERAGE(N2:N" & cnt + 1 & ")"
.Range("Q" & i).Formula = "=SUM(Q2:Q" & cnt + 1 & ")"
.Range("R" & i).Formula = "=AVERAGE(R2:R" & cnt + 1 & ")"
.Range("S" & i & ":T" & i).Formula = "=SUM(S2:S" & cnt + 1 & ")"
.Range("N2:T" & .Cells(.Rows.Count, "M").End(xlUp).Row + 1).Value = .Range("N2:T" & .Cells(.Rows.Count, "M").End(xlUp).Row + 1).Value
End With
Assuming your data is in range Column D to Column J starting from Row 2 and output has to be displayed from Column M to Column S from Row 2 following might be helpful.
Sub Demo()
Dim ws As Worksheet
Dim dataRng As Range
Dim dic As Variant, arr As Variant
Dim cnt As Long
Set ws = ThisWorkbook.Sheets("Sheet4") 'change Sheet4 to your data sheet
Application.ScreenUpdating = False
With ws
lastRow = .Cells(.Rows.Count, "D").End(xlUp).Row 'get last row in Column D
Set dataRng = .Range("D2:D" & lastRow) 'range for Column D
Set dic = CreateObject("Scripting.Dictionary")
arr = dataRng.Value
For i = 1 To UBound(arr)
dic(arr(i, 1)) = dic(arr(i, 1)) + 1
Next
.Range("M2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.keys) 'uniques data from Column D
cnt = dic.Count
For i = 2 To cnt + 1
.Range("N" & i & ":S" & i).Formula = "=SUMIF($D$2:$D$" & lastRow & ",$M" & i & ",E$2:E$" & lastRow & ")/" & dic(.Range("M" & i).Value)
Next i
.Range("N2:S" & .Cells(.Rows.Count, "M").End(xlUp).Row).Value = .Range("N2:S" & .Cells(.Rows.Count, "M").End(xlUp).Row).Value
End With
Application.ScreenUpdating = True
End Sub
This code will give following result.

Match cell value to a combobox row value

I'm trying to figure out a different method of running a piece of code.
Basically what my code is doing at the moment is, looping though column Q in the Global sheet, then looping though Combobox2, when it finds a match the entire rows get moved to the sheet reference in column 1 of the combobox.
Is it possible to use the Match function to achieve the same results and speed up the code??
This is currently the code I'm using, it does what I need it to do, but I cannot get error handling working for it. And it there are many rows of data to loop through it can take a long time!
Option 1:
Private Sub CommandButton6_Click()
Dim i As Long, j As Long, lastG As Long, strWS As String, rngCPY As Range
Dim StartTime As Double
Dim SecondsElapsed As Double
With Application
.ScreenUpdating = False
.EnableEvents = False
.CutCopyMode = False
End With
StartTime = Timer
If Range("L9") = "" Then
MsgBox "You can't Split the Jobs at this stage. " & vbLf & vbLf & "Please create the form for the Sub-Contractor First." & vbLf & vbLf & "Please press Display Utilities to create form.", vbExclamation, "Invalid Operation"
Exit Sub
End If
If sheets("Global").Range("A3") = "" Then
MsgBox "The appears to be no application loaded." & vbLf & vbLf & "Please load" & " " & Range("C11") & " " & "App and Planet Info, then click button 2 and try again.", vbExclamation, "Invalid Operation"
Exit Sub
End If
On Error GoTo bm_Close_Out
' find last row
lastG = sheets("Global").Cells(Rows.Count, "Q").End(xlUp).row
If InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
If sheets("PAYMENT FORM").Range("L40") >= 1 Then
MsgBox "It appears you have already split the jobs, this operation can only be performed once.", vbExclamation, "Invalid Operation"
Exit Sub
Else
For j = 0 To Me.ComboBox2.ListCount - 1
currval = Me.ComboBox2.List(j, 0) ' value to match
For i = 3 To lastG
lookupVal = sheets("Global").Cells(i, "Q") ' value to find
If lookupVal = currval Then
Set rngCPY = sheets("Global").Cells(i, "Q").EntireRow
strWS = Me.ComboBox2.List(j, 1)
On Error GoTo bm_Need_Worksheet '<~~ if the worksheet in the next line does not exist, go make one
With Worksheets(strWS)
rngCPY.Copy
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Insert shift:=xlDown
End With
End If
Next i
Next j
End If
Else
If sheets("PAYMENT FORM").Range("L35") >= 1 Then
MsgBox "It appears you have already split the jobs, this operation can only be performed once.", vbExclamation, "Invalid Operation"
Exit Sub
Else
For j = 0 To Me.ComboBox2.ListCount - 1
currval = Me.ComboBox2.List(j, 0) ' value to match
For i = 3 To lastG
lookupVal = sheets("Global").Cells(i, "Q") ' value to find
If lookupVal = currval Then
Set rngCPY = sheets("Global").Cells(i, "Q").EntireRow
strWS = Me.ComboBox2.List(j, 1)
On Error GoTo bm_Need_Worksheet '<~~ if the worksheet in the next line does not exist, go make one
With Worksheets(strWS)
rngCPY.Copy
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Insert shift:=xlDown
End With
End If
Next i
Next j
End If
End If
GoTo bm_Close_Out
bm_Need_Worksheet:
On Error GoTo 0
With Worksheet
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsTemplate As Worksheet: Set wsTemplate = wb.sheets("Template")
Dim wsPayment As Worksheet: Set wsPayment = wb.sheets("Payment Form")
Dim wsNew As Worksheet
Dim lastRow2 As Long
Dim Contract As String: Contract = sheets("Payment Form").Range("C9").value
Dim SpacePos As Integer: SpacePos = InStr(Contract, "- ")
Dim Name As String: Name = Left(Contract, SpacePos)
Dim Name2 As String: Name2 = Right(Contract, Len(Contract) - Len(Name))
Dim NewName As String: NewName = strWS
Dim CCName As Variant: CCName = Me.ComboBox2.List(j, 2)
Dim LastRow As Long: LastRow = wsPayment.Range("U36:U53").End(xlDown).row
If InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
lastRow2 = wsPayment.Range("A23:A39").End(xlDown).row
Else
lastRow2 = wsPayment.Range("A18:A34").End(xlDown).row
End If
wsTemplate.Visible = True
wsTemplate.Copy before:=sheets("Details"): Set wsNew = ActiveSheet
wsTemplate.Visible = False
If InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
With wsPayment
For Each cell In .Range("A23:A39")
If Len(cell) = 0 Then
If sheets("Payment Form").Range("C9").value = "Network" Then
cell.value = NewName & " - " & Name2 & ": " & CCName
Else
cell.value = NewName & " -" & Name2 & ": " & CCName
End If
Exit For
End If
Next cell
End With
Else
With wsPayment
For Each cell In .Range("A18:A34")
If Len(cell) = 0 Then
If sheets("Payment Form").Range("C9").value = "Network" Then
cell.value = NewName & " - " & Name2 & ": " & CCName
Else
cell.value = NewName & " -" & Name2 & ": " & CCName
End If
Exit For
End If
Next cell
End With
End If
If InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
With wsNew
.Name = NewName
.Range("D4").value = wsPayment.Range("A23:A39").End(xlDown).value
.Range("D6").value = wsPayment.Range("L11").value
.Range("D8").value = wsPayment.Range("C9").value
.Range("D10").value = wsPayment.Range("C11").value
End With
Else
With wsNew
.Name = NewName
.Range("D4").value = wsPayment.Range("A18:A34").End(xlDown).value
.Range("D6").value = wsPayment.Range("L11").value
.Range("D8").value = wsPayment.Range("C9").value
.Range("D10").value = wsPayment.Range("C11").value
End With
End If
wsPayment.Activate
With wsPayment
.Range("J" & lastRow2 + 1).value = 0
.Range("L" & lastRow2 + 1).Formula = "=N" & lastRow2 + 1 & "-J" & lastRow2 + 1 & ""
.Range("N" & lastRow2 + 1).Formula = "='" & NewName & "'!L20"
.Range("U" & LastRow + 1).value = NewName & ": "
.Range("V" & LastRow + 1).Formula = "='" & NewName & "'!I21"
.Range("W" & LastRow + 1).Formula = "='" & NewName & "'!I23"
.Range("X" & LastRow + 1).Formula = "='" & NewName & "'!K21"
End With
End With
On Error GoTo bm_Close_Out
Resume
bm_Close_Out:
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
With Application
.ScreenUpdating = True
.EnableEvents = True
.CutCopyMode = True
End With
End Sub
Option 2:
Private Sub CommandButton1_Click()
Dim j As Long, strWS As String, rngCPY As Range, FirstAddress As String, sSheetsWithData As String
Dim sSheetsWithoutData As String, lSheetRowsCopied As Long, lAllRowsCopied As Long, bFound As Boolean, sOutput As String
Dim StartTime As Double
Dim SecondsElapsed As Double
With Application
.ScreenUpdating = False
.EnableEvents = False
.CutCopyMode = False
.EnableEvents = False
End With
StartTime = Timer
On Error GoTo bm_Close_Out
For j = 0 To UserForm2.ComboBox2.ListCount - 1
bFound = False
currval = UserForm2.ComboBox2.List(j, 0) ' value to match
With sheets("Global")
Set rngCPY = sheets("Global").Range("Q:Q").Find(currval, LookIn:=xlValues)
If Not rngCPY Is Nothing Then
bFound = True
lSheetRowsCopied = 0
FirstAddress = rngCPY.Address
Do
lSheetRowsCopied = lSheetRowsCopied + 1
strWS = UserForm2.ComboBox2.List(j, 1)
On Error GoTo bm_Need_Worksheet
With Worksheets(strWS)
rngCPY.EntireRow.Copy
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Insert shift:=xlDown
End With
Set rngCPY = sheets("Global").Range("Q:Q").FindNext(rngCPY)
Loop Until rngCPY Is Nothing Or rngCPY.Address = FirstAddress
Else
bFound = False
End If
If bFound Then
sSheetsWithData = sSheetsWithData & " " & strWS & " (" & lSheetRowsCopied & ")" & vbLf
lAllRowsCopied = lAllRowsCopied + lSheetRowsCopied
End If
End With
Next j
bm_Need_Worksheet:
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsTemplate As Worksheet: Set wsTemplate = wb.sheets("Template")
Dim wsPayment As Worksheet: Set wsPayment = wb.sheets("Payment Form")
Dim wsNew As Worksheet
Dim lastRow2 As Long
Dim Contract As String: Contract = sheets("Payment Form").Range("C9").value
Dim SpacePos As Integer: SpacePos = InStr(Contract, "- ")
Dim Name As String: Name = Left(Contract, SpacePos)
Dim Name2 As String: Name2 = Right(Contract, Len(Contract) - Len(Name))
Dim NewName As String: NewName = strWS
Dim CCName As Variant: CCName = UserForm2.ComboBox2.List(j, 2)
Dim LastRow As Long: LastRow = wsPayment.Range("U36:U53").End(xlDown).row
If InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
lastRow2 = wsPayment.Range("A23:A39").End(xlDown).row
Else
lastRow2 = wsPayment.Range("A18:A34").End(xlDown).row
End If
wsTemplate.Visible = True
wsTemplate.Copy before:=sheets("Details"): Set wsNew = ActiveSheet
wsTemplate.Visible = False
If InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
With wsPayment
For Each cell In .Range("A23:A39")
If Len(cell) = 0 Then
If sheets("Payment Form").Range("C9").value = "Network" Then
cell.value = NewName & " - " & Name2 & ": " & CCName
Else
cell.value = NewName & " -" & Name2 & ": " & CCName
End If
Exit For
End If
Next cell
End With
Else
With wsPayment
For Each cell In .Range("A18:A34")
If Len(cell) = 0 Then
If sheets("Payment Form").Range("C9").value = "Network" Then
cell.value = NewName & " - " & Name2 & ": " & CCName
Else
cell.value = NewName & " -" & Name2 & ": " & CCName
End If
Exit For
End If
Next cell
End With
End If
If InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
With wsNew
.Name = NewName
.Range("D4").value = wsPayment.Range("A23:A39").End(xlDown).value
.Range("D6").value = wsPayment.Range("L11").value
.Range("D8").value = wsPayment.Range("C9").value
.Range("D10").value = wsPayment.Range("C11").value
End With
Else
With wsNew
.Name = NewName
.Range("D4").value = wsPayment.Range("A18:A34").End(xlDown).value
.Range("D6").value = wsPayment.Range("L11").value
.Range("D8").value = wsPayment.Range("C9").value
.Range("D10").value = wsPayment.Range("C11").value
End With
End If
wsPayment.Activate
With wsPayment
.Range("J" & lastRow2 + 1).value = 0
.Range("L" & lastRow2 + 1).Formula = "=N" & lastRow2 + 1 & "-J" & lastRow2 + 1 & ""
.Range("N" & lastRow2 + 1).Formula = "='" & NewName & "'!L20"
.Range("U" & LastRow + 1).value = NewName & ": "
.Range("V" & LastRow + 1).Formula = "='" & NewName & "'!I21"
.Range("W" & LastRow + 1).Formula = "='" & NewName & "'!I23"
.Range("X" & LastRow + 1).Formula = "='" & NewName & "'!K21"
End With
On Error GoTo bm_Close_Out
Resume
bm_Close_Out:
If sSheetsWithData <> vbNullString Then
sOutput = "# of rows copied to sheets:" & vbLf & vbLf & sSheetsWithData & vbLf & _
"Total rows copied = " & lAllRowsCopied & vbLf & vbLf
Else
sOutput = "No sheets contained data to be copied" & vbLf & vbLf
End If
If sSheetsWithoutData <> vbNullString Then
sOutput = sOutput & "Sheets with no rows copied:" & vbLf & vbLf & sSheetsWithoutData
Else
sOutput = sOutput & "All sheets had data that was copied."
End If
If sOutput <> vbNullString Then MsgBox sOutput, , "Copy Report"
Set rngCPY = Nothing
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
With Application
.ScreenUpdating = True
.EnableEvents = True
.CutCopyMode = True
.EnableEvents = True
End With
End Sub
OK... It's more like a try than an answer. pls check if that is working and if it is faster.
Use this macro only with a copy of your workbook!
Private Sub CommandButton2_Click()
Dim i As Long, j As Long, k As Long, strWS As String, rngCPY As Range
Dim noFind As Variant: noFind = UserForm2.ComboBox2.List '<~~~ get missed items
With Application: .ScreenUpdating = False: .EnableEvents = False: .CutCopyMode = False: End With
If Range("L9") = "" Then: MsgBox "You can't Split the Jobs at this stage. " & vbLf & vbLf & "Please create the form for the Sub-Contractor First." & vbLf & vbLf & "Please press Display Utilities to create form.", vbExclamation, "Invalid Operation": Exit Sub
Dim lastG As Long: lastG = Sheets("Global").Cells(Rows.Count, 17).End(xlUp).row
Dim cVat As Boolean: cVat = InStr(1, Sheets("Payment Form").Range("A20").Value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE")
If Sheets("PAYMENT FORM").Cells(35 - cVat * 5, 12) >= 1 Then: MsgBox "It appears you have already split the jobs, this operation can only be performed once.", vbExclamation, "Invalid Operation": Exit Sub
'~~~ acivate next line to sort (will speed up a lot)
'Sheets("Global").Range("A3:R" & Cells(Rows.Count, 17).End(xlUp).row).Sort cells(3,17), 1
For j = 0 To UserForm2.ComboBox2.ListCount - 1
noFind(j, 4) = 0
For i = 3 To lastG
If noFind(j, 0) = Sheets("Global").Cells(i, 17) Then
k = i
strWS = UserForm2.ComboBox2.List(j, 1)
On Error Resume Next
If Len(Worksheets(strWS).Name) = 0 Then
With ThisWorkbook
On Error GoTo 0
Dim nStr As String: With Sheets("Payment Form").Range("C9"): nStr = Right(.Value, Len(.Value) - Len(Left(.Value, InStr(.Value, "- ")))): End With
Dim CCName As Variant: CCName = UserForm2.ComboBox2.List(j, 2)
Dim lastRow As Long: lastRow = Sheets("Payment Form").Range("U36:U53").End(xlDown).row + 1
Dim strRng As String: strRng = Array("A18:A34", "A23:A39")(-1 * cVat)
Dim lastRow2 As Long: lastRow2 = Sheets("Payment Form").Range(strRng).End(xlDown).row + 1
Dim wsNew As Worksheet: .Sheets("Template").Copy .Sheets(.Sheets.Count): Set wsNew = .Sheets(.Sheets.Count): wsNew.Move .Sheets("Details")
With Sheets("Payment Form")
For Each cell In .Range(strRng)
If Len(cell) = 0 Then
If Sheets("Payment Form").Range("C9").Value = "Network" Then
cell.Offset.Value = strWS & " - " & nStr & ": " & CCName
Else
cell.Offset.Value = strWS & " -" & nStr & ": " & CCName
End If
Exit For
End If
Next cell
End With
With wsNew
.Visible = -1
.Name = strWS
.Cells(4, 4).Value = Sheets("Payment Form").Range(strRng).End(xlDown).Value
.Cells(6, 4).Value = Sheets("Payment Form").Cells(12, 12).Value
.Cells(8, 4).Value = Sheets("Payment Form").Cells(9, 3).Value
.Cells(10, 4).Value = Sheets("Payment Form").Cells(11, 3).Value
End With
With .Sheets("Payment Form")
.Activate
.Cells(lastRow2, 10).Value = 0
.Cells(lastRow2, 12).Formula = "=N" & lastRow2 & "-J" & lastRow2 & ""
.Cells(lastRow2, 14).Formula = "='" & strWS & "'!L20"
.Cells(lastRow, 21).Value = strWS & ": "
.Cells(lastRow, 22).Formula = "='" & strWS & "'!I21"
.Cells(lastRow, 23).Formula = "='" & strWS & "'!I23"
.Cells(lastRow, 24).Formula = "='" & strWS & "'!K21"
End With
End With
End If
On Error GoTo 0
While Sheets("Global").Cells(k + 1, 17).Value = noFind(j, 0) And k < lastG
k = k + 1
Wend
Set rngCPY = Sheets("Global").Range("Q" & i & ":Q" & k).EntireRow
With Worksheets(strWS)
rngCPY.Copy
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Insert shift:=xlDown
End With
noFind(j, 4) = noFind(j, 4) + k - i + 1
i = k
End If
Next i
Next j
With Application: .ScreenUpdating = True: .EnableEvents = True: .CutCopyMode = True: End With
'noFind(x, y) > x = item / y: 0 = name / y: 4 = counter
noFind(0, 0) = noFind(0, 0) & " " & noFind(0, 4) & " times copied"
For i = 1 To UBound(noFind)
noFind(0, 0) = noFind(0, 0) & vbLf & noFind(i, 0) & " " & noFind(i, 4) & " times copied"
Next
MsgBox noFind(0, 0)
End Sub
At first: you may add some empty lines for better understanding...
Most parts are just shortened by view (they still do tha same).
When using the sort option, it will copy/paste all rows for each keyword in one step. That not only sounds faster... However, you may resort at the end again
Pls check if it works with your real workbook (copy of it, but with all data inside). I haven't done any "indeep speed tuning".
Here is a small section of your code that replace the loop through each cell in Global!Q3:Q*<last_row>* with the VBA version of the MATCH function.
Dim rw As Long, rngGQs As Range '<~~ put this closer to the top with the other variable declarations
' find last row
'lastG = Sheets("Global").Cells(Rows.Count, "Q").End(xlUp).Row '<~~old way
With Sheets("Global") '<~~new way
Set rngGQs = .Range(Cells(3, "Q"), .Cells(Rows.Count, "Q").End(xlUp)) '< ~~ all of the cells to look at
End With
If InStr(1, Sheets("Payment Form").Range("A20").Value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
If Sheets("PAYMENT FORM").Range("L40") >= 1 Then
MsgBox "It appears you have already split the jobs, this operation can only be performed once.", vbExclamation, "Invalid Operation"
Exit Sub
Else
For j = 0 To Me.ComboBox2.ListCount - 1
currval = Me.ComboBox2.List(j, 0) ' value to match
'For i = 3 To lastG '<~~old way
'lookupVal = Sheets("Global").Cells(i, "Q") ' value to find
'If lookupVal = currval Then
If Not IsError(Application.Match(currval, rngGQs, 0)) Then '<~~new way
rw = Application.Match(currval, rngGQs, 0)
Set rngCPY = Sheets("Global").Cells(rw, "Q").EntireRow
'all the rest here
When you get this to a satisfactory working order, it will be a prime candidate for suggestions at Code Review (Excel).
You could try something like this. The Range.Find-Method basically looks through the given range for a value which you can specify. If a match is found, the cell in which the match is found, can then be stored.
You can then also use .FindNext to find the next occurrence of that value, if needed.
For j = 0 To Me.ComboBox2.ListCount - 1
currval = Me.ComboBox2.List(j, 0) ' value to match
Set rngCPY = sheets("Global").Range("Q:Q").Find(currval, LookIn:=xlValues)
Do While Not rngCPY Is Nothing
strWs = Me.ComboBox2.List(j, 1)
rngCPY.EntireRow.Copy
With Worksheets(strWS)
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Insert shift:=xlDown
End With
Set rngCPY = sheets("Global").Range("Q:Q").FindNext(rngCPY)
Loop
Next j

Find matching cell with different strings inside one cell

My goal of my macro:
I have 2 sheets, sheet1 master report and sheet2 import Input.
In column A of both sheets I have several strings in one cell.
I would like to see if there is a match and if there is the match the row from sheet2 (from column B) will be copied and paste in the row corresponding in sheet1.
This part of my code is done.
But now it starts to be tricky: If there is new string in the same cell as the matching string so I would like to add them as well in the cell of the column A sheet1.
For instance:
Sheet1 Column A Cell34:
MDM-9086
Sheet2 Column A Cell1:
MDM-9086,MDM-12345
After the macro it would be like this:
Sheet1 Column A cell34:
MDM-9086,MDM-12345
If there is no match between column A of both sheets so I would like to copy the entire row of the sheet2 and past it in the last free row of the sheet1.
See my code:
Sub MDMNumbers()
Dim LastRw1 As Long, LastRw2 As Long, NxtRw As Long
Dim I As Integer
Dim m As Range
Dim Tb
LastRw1 = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
LastRw2 = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row
With Worksheets(2)
LastRw2 = .Range("A" & Rows.Count).End(xlUp).Row
For NxtRw = 2 To LastRw2
Tb = Split(.Range("A" & NxtRw), ",")
For I = 0 To UBound(Tb)
With Sheets(1).Range("A2:A" & LastRw1)
Set m = .Find(Trim(Tb(I)), LookAt:=xlPart)
If Not m Is Nothing Then
Sheets(2).Range("B" & NxtRw & ":Q" & NxtRw).Copy _
Sheets(1).Range("B" & m.Row)
Set m = Nothing
End If
End With
Next I
Next NxtRw
End With
End Sub
Example:
Sheet 1, Column A (start row 2)
MDM-123,MDM-27827
MDM-1791728,MDM-124
MDM-125
MDM-126,MDM-28920
MDM-127,MDM-1008
""
Sheet 2, Column A (start row 2)
MDM-123,MDM-27272
MDM-124
MDM-125,MDM-1289
MDM-126
MDM-1008
MDM-127
MDM-172891
Result on Sheet 1, Column A (start row 2):
MDM-123,MDM-27827,MDM-27272
MDM-124,MDM-1791728
MDM-125,MDM-1289
MDM-126,MDM-28920
MDM-127,MDM-1008
MDM-1008
MDM-172891
For your # 2.
Option Explicit
Public Sub MDMNumbers()
Dim LastRw1 As Long, LastRw2 As Long, NxtRw As Long, rng1 As Range, rng2 As Range
Dim i As Long, m As Range, tb() As String, celVal As String, notFound As Boolean
Dim additions1 As String, additions2 As String
LastRw1 = Worksheets(1).Range("A" & Worksheets(1).Rows.Count).End(xlUp).Row + 1
LastRw2 = Worksheets(2).Range("A" & Worksheets(2).Rows.Count).End(xlUp).Row
notFound = True
For NxtRw = 2 To LastRw2
celVal = Worksheets(2).Range("A" & NxtRw).Value2
If Len(celVal) > 0 Then
tb = Split(celVal, ",")
For i = 0 To UBound(tb)
Set m = Worksheets(1).Columns(1).Find(Trim(tb(i)), LookAt:=xlPart)
If Not m Is Nothing And notFound Then
Set rng1 = Worksheets(2).Range("B" & NxtRw & ":Q" & NxtRw)
Set rng2 = Worksheets(1).Range("B" & m.Row & ":Q" & m.Row)
rng1.Copy rng2
With Worksheets(2).Range("A" & NxtRw)
additions1 = Replace(.Value2, "," & tb(i), vbNullString)
additions1 = Replace(additions1, tb(i) & ",", vbNullString)
additions1 = Replace(additions1, tb(i), vbNullString)
End With
With Worksheets(1).Range("A" & m.Row)
additions2 = Replace(.Value2, "," & tb(i), vbNullString)
additions2 = Replace(additions2, tb(i) & ",", vbNullString)
additions2 = Replace(additions2, tb(i), vbNullString)
If Len(additions2) > 0 Then
If Len(additions1) > 0 Then
.Value2 = tb(i) & "," & additions2 & "," & additions1
Else
.Value2 = tb(i) & "," & additions2
End If
Else
.Value2 = tb(i) & "," & additions1
End If
End With
Set m = Nothing
notFound = False
End If
Next
If notFound Then
Set rng1 = Worksheets(2).Range("A" & NxtRw & ":Q" & NxtRw)
Set rng2 = Worksheets(1).Range("A" & LastRw1 & ":Q" & LastRw1)
rng1.Copy rng2
LastRw1 = LastRw1 + 1
End If
notFound = True
End If
Next
End Sub
It should work as expected now
Test data and result:
Why don't you copy the whole row from sheet2 to sheet1 like
For NxtRw = 2 To LastRw2
...
Sheets(2).Range("A" & NxtRw & ":Q" & NxtRw).Copy _
Sheets(1).Range("A" & m.Row)
...
Next NxtRw
? (The rest of the loop should stay the same.)

Comparing two worksheets with different column order

I'm trying to compare two worksheets in excel to find new/updated records using vba.
(assume worksheet 1 is old, and worksheet 2 has the potential new/updated entries)
These sheets have very similar information stored in each, just in a different order.
For example:
Worksheet 1 has Street Address in Column E whereas Worksheet 2 has the street Address in Column H. There are many other columns like this.
I'm not really sure where to start. I tried to rearrange the columns in the second sheet by cutting and inserting to match those of the first, but that got out of hand very quickly.
Also, if its a new record, it needs be appended to the end of the data.
**Updated to allow defining the 'key' column. Just change the line 'iKeyCol = 2' to the desired column.
Here is some code to try. I was too lazy to rework all the code I was using, so some of this may be extra for you. Make sure your workbook
1. Has at least three sheets (names 'Sheet1, Sheet2, NewSheet')
2. Has column headers for Sheet1 & Sheet2
3. Col1 must match in both sheets
4. Column count must match in both sheets.
Other that col1, other columns can be in any order.
Paste the code into a new module and the execute.
Let me know if you have a problem.
Option Explicit
' This module will compare differences between two worksheets.
Sub Compare106thWorksheets()
Dim iKeyCol As Integer
'>>>> CHANGE THE FOLLOWING LINE TO IDENTIFY THE KEY COLUMN
iKeyCol = 2
Dim i, i2, i3 As Integer
Dim iRow As Long
Dim iR1, iR2 As Long
Dim iC1, iC2 As Integer
Dim iColMap(30) As Integer
Dim iCol1, iCol2 As Integer
Dim LastRow1 As Long, LastRow2 As Long
Dim LastCol1 As Integer, LastCol2 As Integer
Dim MaxRow1 As Long
Dim MaxCol1 As Integer
Dim sFld1 As String, sFld2 As String
Dim sFN1, sFN2 As String
Dim rptWB As Workbook
Dim DiffCount As Long
Dim iLastRow, iLastColumn As Integer
Dim strDeleted, strInserted As String
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim wsChg As Worksheet
Dim iCHGRows As Long
Dim iCHGCols As Long
Application.ScreenUpdating = False
Application.StatusBar = "Creating the report..."
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
Set wsChg = ThisWorkbook.Worksheets("NewSheet")
With ws1.UsedRange ' Get used range of Sheet1
LastRow1 = .Rows.Count
LastCol1 = .Columns.Count
End With
With ws2.UsedRange ' Get used range of Sheet1
LastRow2 = .Rows.Count
LastCol2 = .Columns.Count
End With
With wsChg.UsedRange ' Get used range of Sheet1
iCHGRows = .Rows.Count
iCHGCols = LastCol1
End With
MaxRow1 = LastRow1
MaxCol1 = LastCol1
Debug.Print ws1.Name & " has " & LastRow1 & " rows and " & LastCol1 & " columns."
Debug.Print ws2.Name & " has " & LastRow2 & " rows and " & LastCol2 & " columns."
If MaxRow1 < LastRow2 Then MaxRow1 = LastRow2
If MaxCol1 < LastCol2 Then MaxCol1 = LastCol2
' Build a column map. Require both sheets to have the same names - but different order.
For i = 1 To 30
iColMap(i) = 0
Next i
For iC1 = 1 To MaxCol1
For i = 1 To LastCol2
If ws1.Cells(1, iC1) = ws2.Cells(1, i) Then
iColMap(iC1) = i
Exit For
End If
Next i
Next iC1
' Check if any column headers failed to match.
For i = 1 To MaxCol1
If iColMap(i) = 0 Then
MsgBox "Column named '" & ws1.Cells(1, i) & " not found in Sheet2. Please correct and start again."
GoTo Exit_Code
End If
Next i
strDeleted = "": strInserted = ""
iR2 = 1
DiffCount = 0
For iR1 = 1 To MaxRow1
If ws1.Cells(iR1, iKeyCol) <> ws2.Cells(iR2, iKeyCol) Then ' Cell is different - is it an ADD or Delete?
Debug.Print "Row: " & iR1 & vbTab & ws1.Cells(iR1, iKeyCol) & vbTab & "versus: " & ws2.Cells(iR2, iKeyCol)
sFld1 = Trim(ws1.Cells(iR1, iKeyCol).FormulaLocal)
sFld2 = Trim(ws2.Cells(iR2, iKeyCol).FormulaLocal)
If sFld1 < sFld2 Then
Debug.Print "Deleted Row " & ws1.Cells(iR1, iKeyCol)
DiffCount = DiffCount + 1
wsChg.Cells(DiffCount, iKeyCol) = "Deleted:"
wsChg.Cells(DiffCount, 2) = ws1.Cells(iR1, iKeyCol)
strDeleted = strDeleted & ws1.Cells(iR1, iKeyCol) & vbCrLf
iCHGRows = iCHGRows + 1
wsChg.Cells(iCHGRows, 1) = Now()
For i = 1 To LastCol1
wsChg.Cells(iCHGRows, i + 1) = ws1.Cells(iR1, i)
Next i
ws1.Rows(iR1).EntireRow.Delete
iR1 = iR1 - 1
GoTo Its_OK
ElseIf sFld1 > sFld2 Then
Debug.Print "Inserted Row " & ws2.Cells(iR1, iKeyCol)
Debug.Print "R1: " & iR1 & " R2: " & iR2 & vbTab & ws1.Cells(iR1, iKeyCol) & vbTab & "versus: " & ws2.Cells(iR2, iKeyCol)
DiffCount = DiffCount + 1
strInserted = strInserted & ws2.Cells(iR2, iKeyCol) & vbCrLf
ws1.Rows(iR1).EntireRow.Insert
For i = 1 To LastCol1
ws1.Cells(iR1, i) = ws2.Cells(iR2, iColMap(i))
Next i
iR2 = iR2 + 1
GoTo Its_OK
Else
iR2 = iR2 + 1
End If
Else ' Values are the same
iR2 = iR2 + 1
End If
Its_OK:
Next iR1
Debug.Print "Deleted:"
Debug.Print strDeleted
Debug.Print "------------------------------------------------------------------"
Debug.Print "Inserted:"
Debug.Print strInserted
Debug.Print "------------------------------------------------------------------"
For iRow = 2 To LastRow2
Application.StatusBar = "Comparing cells " & Format(iCol1 / MaxCol1, "0 %") & "..."
For iCol1 = 1 To LastCol1
iCol2 = iColMap(iCol1)
sFld1 = ""
sFld2 = ""
On Error Resume Next
sFld1 = ws1.Cells(iRow, iCol1).FormulaLocal
sFld2 = ws2.Cells(iRow, iCol2).FormulaLocal
On Error GoTo 0
If sFld1 <> sFld2 Then
Debug.Print "Row: " & iRow & vbTab & ws1.Cells(iRow, iCol1) & vbTab & "versus: " & ws2.Cells(iRow, iCol2)
DiffCount = DiffCount + 1
wsChg.Cells(DiffCount, 1) = ws1.Cells(iRow, iKeyCol)
wsChg.Cells(DiffCount, 2) = ws1.Cells(1, iCol1)
wsChg.Cells(DiffCount, 3) = sFld1
wsChg.Cells(DiffCount, 4) = sFld2
ws1.Cells(iRow, iCol1).FormulaLocal = ws2.Cells(iRow, iCol2).FormulaLocal
End If
Next iCol1
Next iRow
wsChg.Activate
Application.StatusBar = "Formatting the report..."
With Range(Cells(1, 1), Cells(MaxRow1, MaxCol1))
.Interior.ColorIndex = 19
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
On Error Resume Next
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
On Error GoTo 0
End With
Columns("A:IV").ColumnWidth = 20
MsgBox DiffCount & " cells contain different formulas!", vbInformation, _
"Compare " & ws1.Name & " with " & ws2.Name
Exit_Code:
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub