Automatic Data Transfer Between Worksheets

[Ben60657]

Hi all,

I am having an issue with automatically transferring data from several worksheets into a single summary and analysis worksheet. I receive single worksheet Excel files with data from a hundred people and need to move it to a summary sheet to produce totals, averages, etc., without manually selecting the data and doing copy/paste a hundred times. Is there a way to perform that task? Many thanks!

 

[Ben60657]

John,

Thank you again for the code. It works, moving the information in the selected range over from the files in the "2006 Entries" folder. Is there a way to modify the code to pick out individual cells in the range given, instead of the entire range? An example:

I have five single-worksheet files in my "2006 Entries" folder: Smith 1, Smith 2, Johnson 1, Johnson 2, and Williams 1. Each one of the individual files has a piece of information in cell C3, another in E25, another in M19, etc. In the summary file, I would like to list the C3 information in C3:G3, the E25 information in C4:G4, the M19 information in C5:G5, etc. There are about 25 different pieces of information in the A2:O64 range of the individual files and I would like to be able to summarize in this fashion, instead of moving the entire sheet to the summary file. Any ideas?

 

[Datsmart]

This line of code does the actual copy.

    Range("A2:O64").Copy _ 
    Destination:=basebook.Sheets("Summary").Range("A" & basebook.Sheets("Summary").Range("A65536").End(xlUp).Row + 1)

You could edit it and repeat it for each range of the worksheet you want to copy.
The way you list your data the ranges don't match. You want C3 to be copied to C3:G3. Does that mean you want the data in C3 repeated 5 times in those 5 cells?

If your data will always be in the same exact cells you could hard code the ranges into the code.

    Range("C3").Copy _ 
    Destination:=basebook.Sheets("Summary").Range("C" & basebook.Sheets("Summary").Range("C65536").End(xlUp).Row + 1)
    Range("E25").Copy _ 
    Destination:=basebook.Sheets("Summary").Range("C" & basebook.Sheets("Summary").Range("C65536").End(xlUp).Row + 1)
    Range("M19").Copy _ 
    Destination:=basebook.Sheets("Summary").Range("C" & basebook.Sheets("Summary").Range("C65536").End(xlUp).Row + 1)

 

[Ben60657]

John,

I don't think I was clear with the C3 data transfer to the summary file. What I would want to do with everyone's C3 data:

Put the C3 data from Smith 1's file in C3 of the summary file, Smith 2's C3 data in D3 of the summary file, Johnson 1's C3 data in E3 of the summary file, Johnson 2's C3 data in F3 of the summary file, and Williams 1's C3 data in G3 of the summary file, etc. This would create a row across the summary sheet of everyone's C3 data.

After that, I would like to do the same thing with everyone's E25 data in C4:G4 of the summary file, everyone's M19 data in C5:G5 of the summary file, etc.

Will the updated code you gave me do that?

 

[Datsmart]

OK, this is entirely different. No, the last code will not do this.
Will this request replace the first code request? You no longer want to copy the A2:O64 range?
Your new request is do-able, I just need to know what all you want to happen. Only want the code to open each of the workbooks in the folder one time each.

 

[Datsmart]

This code has been adjusted to copy to Columns rather than Rows.
Also will copy from each worksheet in each workbook file.

Sub Extracting_Data()
Dim basebook As Workbook
Dim mybook As Workbook
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String
Dim ws As Worksheet

SaveDriveDir = CurDir
'MyPath = "D:\0m1739\Miscellaneous\2006 Entries"
MyPath = "C:\~~~\Test"

'file path
ChDrive MyPath
ChDir MyPath

FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If

Application.ScreenUpdating = False
Set basebook = ThisWorkbook
'Assign Column number
LC = Cells(1, Columns.Count).End(xlToLeft).Column

'Open each workbook in folder and copy data
Do While FNames <> ""
    Set mybook = Workbooks.Open(FNames)
    
' If workbook has multiple worksheets, cycle through each sheet
    For Each ws In Worksheets
        Sheets(ws.Name).Select
        ' Get Sheet name in Top Cell
        TabNm = ActiveCell.Parent.Name
        basebook.Sheets("Summary").Cells(1, LC).Value = TabNm
        ' assign variables for Last Row and Last Column
        LR = 3
        LC = LC + 1
        'copy cell values
        Range("C3").Copy _
        Destination:=basebook.Sheets("Summary").Cells(LR, LC)
 
        Range("E25").Copy _
        Destination:=basebook.Sheets("Summary").Cells(LR + 1, LC)
 
        Range("M19").Copy _
        Destination:=basebook.Sheets("Summary").Cells(LR + 2, LC)
        
        'You can add more cells to copy here. Just follow above syntax. Be sure to increment LR.
        
    Next ws

    mybook.Close False
    FNames = Dir()
Loop

ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub

 

[Ben60657]

John,

***Text below was input before I saw your latest code response.***

There are a lot of individual cells that I need from each employee's file and they are all in the range of A2:O64. I don't want to move the whole range because there are a lot of blanks, descriptors, etc., that I don't need. There are about 60 or so (not 25, I looked again and realized there was a bunch of stuff I now know I need) different cells in everyone's individual files that I need to extract.

Everyone has data in C3, E25, M19, etc. I need a row of everyone's C3 data in C3:?3 (depending on number of employees) in the summary worksheet. Below that, I need a row of everyone's E25 data in C4:?4 in the summary worksheet. Below that, everyone's M19 data in C5:?5, and so on. You've done so much already that I can't ask you to code all of them in, so if you could show me one and how to repeat it, I can take care of coding it in the other 58 times.

Thanks again John!

 

[Datsmart]

I think we cross posted.
The last code should do what you want. It also pulls in the worksheet name and pastes that to row 1.

 

[Ben60657]

John,

I think that's it! I tested inserting a few more of the copies of the directional copying and it works. The only thing I can see is that it's putting the worksheet names in A1:E1 and the data in B3:F3, but I think I can fix it. Thanks again!

 

[Datsmart]

Change

LR = 3

to

LR = 2

That sets the Last Row variable (LR) to the first row where new data is pasted.

 

[Ben60657]

John,

Hi and thanks again!

The change in code moved the data start from B3:F3 to B2:F2, and the worksheet names are still in A1:E1, so the data starts one cell to the right of the worksheet name it is derived from.