Forum

Macro to open multi...
 
Notifications
Clear all

Macro to open multiple files and extracts data from them

2 Posts
2 Users
0 Reactions
108 Views
(@paulandreaoc97)
Posts: 1
New Member
Topic starter
 

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: 

  1. Sub Consolidate_Data()
  2. Application.ScreenUpdating = False
  3. Dim wb As Workbook, sh As Worksheet, dsh As Worksheet, File_Name As Variant, i As Long, lr As Long, x As Long
  4. Dim desWS As Worksheet, srcWS As Worksheet, r As Long: r = 6
  5. Set dsh = ThisWorkbook.Sheets("Sheet1")
  6. dsh.UsedRange.ClearContents
  7. File_Name = Application.GetOpenFilename("Excel Files (*.xl*),*.xl*", , "Select Excel Files To Consolidate", , True)
  8. For i = LBound(File_Name) To UBound(File_Name)
  9. Set wb = Workbooks.Open(File_Name(i))
  10. If Not Evaluate("isref('" & "ExtractedData" & "'!A1)") Then
  11. Sheets.Add before:=Sheets(1)
  12. ActiveSheet.Name = "ExtractedData"
  13. Range("A1").Resize(, 5) = Array("Classification", "Inspector", "Standard", "Requirement", "Classification Rilievi")
  14. Columns.AutoFit
  15. Else
  16. Sheets("ExtractedData").UsedRange.Offset(1).ClearContents
  17. End If
  18. Set desWS = Sheets("ExtractedData")
  19. Set srcWS = Sheets("report stampabile")
  20. lr = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  21. For x = 5 To lr Step 10
  22. Select Case srcWS.Range("P" & x).Value
  23. Case "NC", "OSS", "COM"
  24. With desWS
  25. .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))
  26. With Sheets(r)
  27. Select Case .Range("P5").Value
  28. Case "OSS", "NC", "COM"
  29. desWS.Cells(desWS.Rows.Count, "E").End(xlUp).Offset(1) = Sheets(r).Range("P5")
  30. r = r + 1
  31. If desWS.Cells(desWS.Rows.Count, "E").End(xlUp) = 0 Then
  32. desWS.Cells(desWS.Rows.Count, "E").End(xlUp) = ""
  33. End If
  34. End Select
  35. End With
  36. End With
  37. End Select
  38. Next x
  39. With desWS
  40. .Columns.AutoFit
  41. .UsedRange.Copy dsh.Cells(dsh.Rows.Count, "A").End(xlUp).Offset(1)
  42. End With
  43. wb.Close False
  44. r = 6
  45. Next i
  46. With dsh
  47. .Rows(1).Delete
  48. .Columns.AutoFit
  49. End With
  50. Application.ScreenUpdating = True
  51. End Sub
 
Posted : 01/05/2020 9:09 am
(@purfleet)
Posts: 412
Reputable Member
 

Can you please add a sample workbook so we dont have to recreate all the data

 
Posted : 01/05/2020 3:00 pm
Share: