I am trying to add some information to this code and I am a little confuse, maybe someone can help me this time too:
1. I would like to add a column (in column A) calls "Laboratory" that extracts the information of cell P2 of the "report stampabile"
2. To add a column (in column B) calls "Evaluation Date" that extracts the infomation of cell I3 from "report stampabile"
3. To add a column (in column C) calls "Technical Functionary" that extract the informationof cell E18 from "Rilievo 1"
4. To add a column (in column F) calls "Inspector 2" that extract the information of d14,d24,d34 etc from "report stampabile"
the file attached is the one that have to be used to extract the data
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
Dim desWS As Worksheet, srcWS As Worksheet, r As Long: r = 6
Set dsh = ThisWorkbook.Sheets("Sheet1")
dsh.UsedRange.ClearContents
File_Name = Application.GetOpenFilename("Excel Files (*.xl*),*.xl*", , "Select Excel Files To Consolidate", , True)
For i = LBound(File_Name) To UBound(File_Name)
Set wb = Workbooks.Open(File_Name(i))
If Not Evaluate("isref('" & "ExtractedData" & "'!A1)") Then
Sheets.Add before:=Sheets(1)
ActiveSheet.Name = "ExtractedData"
Range("A1").Resize(, 5) = Array("Classification", "Inspector", "Standard", "Requirement", "Classification Rilievi")
Columns.AutoFit
Else
Sheets("ExtractedData").UsedRange.Offset(1).ClearContents
End If
Set desWS = Sheets("ExtractedData")
Set srcWS = 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(.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 4).Value = Array(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))
With Sheets(r)
Select Case .Range("P5").Value
Case "OSS", "NC", "COM"
desWS.Cells(desWS.Rows.Count, "E").End(xlUp).Offset(1) = Sheets(r).Range("P5")
r = r + 1
If desWS.Cells(desWS.Rows.Count, "E").End(xlUp) = 0 Then
desWS.Cells(desWS.Rows.Count, "E").End(xlUp) = ""
End If
End Select
End With
End With
End Select
Next x
With desWS
.Columns.AutoFit
.UsedRange.Copy dsh.Cells(dsh.Rows.Count, "A").End(xlUp).Offset(1)
End With
wb.Close False
r = 6
Next i
With dsh
.Rows(1).Delete
.Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub