New Member
April 30, 2020
Hi to all of you, I am working in a project in VBA and I am trying to add some information to the following code and I am a little confuse, maybe someone can help:
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"
files attached are the ones that have to be used to be opened and extract the data
This is the code I have:
- 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
1 Guest(s)