I am working in this code and I would like to add one more column call "Rilievo Reformulated" (after the classificatioon Rilievi), the idea is compare if cells corresponding to classification and classification rilievi are the same, if both are the same write (NO) if they are different write (YES)
Code
Sub Consolidate_Data()
Application.ScreenUpdating = False
Dim wb As Workbook, sh As Worksheet, dsh As Worksheet, File_Name As Variant, i As Long, lr As Long, x As Long, y As Long
Dim desWS As Worksheet, srcWS As Worksheet, r As Long: r = 6
Set dsh = ThisWorkbook.Sheets("Report")
dsh.UsedRange.ClearContents
dsh.Range("A1").Resize(, 9) = Array("Laboratory", "Evaluation Date", "Technical Functionary", "Classification", "Inspector", "Inspector 2", "Standard", "Requirement", "Classification Rilievi")
File_Name = Application.GetOpenFilename("Excel Files (*.xl*),*.xl*", , "Select Excel Files To Consolidate", , True)
For i = LBound(File_Name) To UBound(File_Name)
y = 2
Set wb = Workbooks.Open(File_Name(i))
If Not Evaluate("isref('" & "ExtractedData" & "'!A1)") Then
Sheets.Add before:=Sheets(1)
With ActiveSheet
.Name = "ExtractedData"
.Range("A1").Resize(, 9) = Array("Laboratory", "Evaluation Date", "Technical Functionary", "Classification", "Inspector", "Inspector 2", "Standard", "Requirement", "Classification Rilievi")
End With
Columns.AutoFit
Else
With ActiveWorkbook.Sheets("ExtractedData")
.UsedRange.Offset(1).ClearContents
.Range("A1").Resize(, 9) = Array("Laboratory", "Evaluation Date", "Technical Functionary", "Classification", "Inspector", "Inspector 2", "Standard", "Requirement", "Classification Rilievi")
End With
End If
Set desWS = ActiveWorkbook.Sheets("ExtractedData")
Set srcWS = ActiveWorkbook.Sheets("report stampabile")
lr = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For x = 5 To lr Step 10
Select Case srcWS.Range("P" & x).Value
Case "NC", "OSS", "COM"
With desWS
.Cells(y, "A").Resize(, 2).Value = _
Array(srcWS.Range("P" & x).Offset(-3), srcWS.Range("P" & x).Offset(-2, -7)) ', srcWS.Range("P" & x), srcWS.Range("P" & x).Offset(6, -12), srcWS.Range("P" & x).Offset(1, -13)) ', srcWS.Range("P" & x).Offset(1, -9))
.Cells(y, "D").Resize(, 2).Value = _
Array(srcWS.Range("P" & x), srcWS.Range("P" & x).Offset(6, -12))
.Cells(y, "F").Resize(, 3).Value = _
Array(srcWS.Range("P" & x).Offset(9, -12), srcWS.Range("P" & x).Offset(1, -13), srcWS.Range("P" & x).Offset(1, -9))
With ActiveWorkbook.Sheets(r)
Select Case .Range("P5").Value
Case "OSS", "NC", "COM"
desWS.Cells(y, "C") = Sheets(r).Range("E18")
desWS.Cells(y, "I") = Sheets(r).Range("P5")
desWS.Cells(y, "A") = Sheets(r).Range("P2")
desWS.Cells(y, "B") = Sheets(r).Range("H3")
r = r + 1
If desWS.Cells(y, "I") = 0 Then
desWS.Cells(y, "I") = ""
End If
End Select
End With
y = y + 1
End With
End Select
Next x
With desWS
.Columns.AutoFit
.UsedRange.Offset(1).Copy dsh.Cells(dsh.Rows.Count, "A").End(xlUp).Offset(1)
End With
'wb.Close False
r = 6
Next i
With dsh
.Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub