Hi guys, I have this code that opens multiple files and then extract data from those files and put it in a new sheet, I would like to eliminate the headers in every single file the Macro opens, I just want to keep the headers (laboratory, evaluation date, technical fucnionary etc) in the first row (a1,b1,c1,d1,e1,f1,g1,h1,i1).
The attachments are some files I need to open
2019-11-11_MD-09-03-DT.xlsm2020-02-02_MD-09-03-DT.xlsm2019-11-11_MD-09-03-DT.xlsm2020-02-02_MD-09-03-DT.xlsm2019-11-11_MD-09-03-DT.xlsm2020-02-02_MD-09-03-DT.xlsm
Thank you for you help
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("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)
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.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