How to extract certain cells from all sheets in workbook to a new workbook?

[ckdragon]

Hi there,

I have a heap of workbooks that have specific data I need to extract, some of the work books might have 20 sheets in them and I am wondering if there is a way to set up an automatic copy and paste to another new workbook.

The data I need to extract is located in B20:G23 across all sheets in my workbook but I then need it pasted it into a new workbook starting at A2.

Some of the cells in B20:G23 in some sheets are actually empty though, so I only need it to take the ones that have information.

I have 30 or so workbooks I need to run this on and extract all this data into this one new workbook, so it would need to paste to the next empty row.

Is there a macro that I could write to get this to work, so I dont have to manually copy and paste everything?

I have tried to have a look to see if there was any base code I can use, but can't seem to find anything

Any help would be super appreciated.

Thank you!

 

[HongRu]

try this.

Sub sbExtractData()
    Application.ScreenUpdating = False
    Dim myWb1 As Workbook
    Set myWb1 = ThisWorkbook
    
    Dim mySht As Worksheet
    Set mySht = myWb1.Worksheets(1)
    mySht.Range("A1") = "Data"
    
    Dim myWb2 As Workbook
    
    Dim myFolder
    myFolder = "D:\test\"
    
    Dim myFile
    myFile = Dir(myFolder)
    Set myWb2 = Workbooks.Open(myFolder & myFile)
    Dim e As Worksheet
    Do Until myFile = ""
        Set myWb2 = Workbooks.Open(myFolder & myFile)
        For Each e In myWb2.Worksheets
            e.Range("B20:G23").Copy
            mySht.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        Next e
        myWb2.Close
        myFile = Dir()
    Loop
    mySht.Range("A1").Select
    
    Set mySht = Nothing
    Set myWb2 = Nothing
    Set myWb1 = Nothing
End Sub

 

[ckdragon]

try this.

Sub sbExtractData()
    Application.ScreenUpdating = False
    Dim myWb1 As Workbook
    Set myWb1 = ThisWorkbook
   
    Dim mySht As Worksheet
    Set mySht = myWb1.Worksheets(1)
    mySht.Range("A1") = "Data"
   
    Dim myWb2 As Workbook
   
    Dim myFolder
    myFolder = "D:\test\"
   
    Dim myFile
    myFile = Dir(myFolder)
    Set myWb2 = Workbooks.Open(myFolder & myFile)
    Dim e As Worksheet
    Do Until myFile = ""
        Set myWb2 = Workbooks.Open(myFolder & myFile)
        For Each e In myWb2.Worksheets
            e.Range("B20:G23").Copy
            mySht.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        Next e
        myWb2.Close
        myFile = Dir()
    Loop
    mySht.Range("A1").Select
   
    Set mySht = Nothing
    Set myWb2 = Nothing
    Set myWb1 = Nothing
End Sub

Thank you. I will give it a go

Just a question. Do I paste this in the new workbook where I want the data pasted and does this work through all the workbooks and sheets saved in the “my folder” pathway?

 

[HongRu]

Thank you. I will give it a go

Just a question. Do I paste this in the new workbook where I want the data pasted and does this work through all the workbooks and sheets saved in the “my folder” pathway?

Yes.
You can open a new workbook and copy my code in the new workbook's vba module.
The code will go through all the workbooks and sheets in the "myFolder".
Note that files in the "myFolder" should be EXCEL files you want to extract, or maybe error.