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!

 

[Datsmart]

Put some text in cell B1. My text page had data there because you said you had description text in columns A and B. The code set the column number variable by the first empty cell in row 1.

 

[Ben60657]

This is going to save me hours!

I hate to bug you with little questions, but is there a way to modify the copying code to move values only? I am moving over a lot of fonts, borders, etc., that I have to go back in and remove after every data transfer.

 

[Datsmart]

At this point it would be easier to just change the format of the Summary sheet after the transfer takes place.
To build code that sets new font, etc at the end of the transfer I will need to know what font, font size, borders etc. to you want to use? Can't just set it to nothing.

 

[Ben60657]

I agree and I don't want you to write more code on my behalf. You've been very helpful and I can now do in a couple of hours what would've taken many, many more. I know it probably won't happen, but if you get stumped with something and think I can help, let me know. Thanks again John!

 

[Ben60657]

John,

One quick addendum -

How can I change the name at the top to pull in the file name instead of the worksheet name? I will specify for future work that each file is to have only a single worksheet. Thanks!

 

[Datsmart]

Change this code;

        ' Get Sheet name in Top Cell
        TabNm = ActiveCell.Parent.Name
        basebook.Sheets("Summary").Cells(1, LC).Value = TabNm

to this;

        ' Get File name in Top Cell
        WBname = ActiveWorkbook.Name
        basebook.Sheets("Summary").Cells(1, LC).Value = WBname

If you want both File name and sheet name use this.

        TabNm = ActiveCell.Parent.Name
        WBname = ActiveWorkbook.Name
        basebook.Sheets("Summary").Cells(1, LC).Value = WBname
        basebook.Sheets("Summary").Cells(2, LC).Value = TabNm

File name will be in row 1, sheetname will be in row 2.

 

[able83]

Here is some code I put together that should help you.

Sub Extracting_Data()
Dim basebook As Workbook
Dim mybook As Workbook
Dim rnum As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String
Dim Cnum As Integer
Dim cell As Range

SaveDriveDir = CurDir
MyPath = "D:\0m1739\Miscellaneous\2006 Entries"

'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

Do While FNames <> ""
    Set mybook = Workbooks.Open(FNames)
    
    ' Copy range to Destination, copies to end of data on Summary page.
    Range("A2:O64").Copy _
    Destination:=basebook.Sheets("Summary").Range("A" & basebook.Sheets("Summary").Range("A65536").End(xlUp).Row + 1)
    
    mybook.Close False
    FNames = Dir()
Loop

ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub

This will copy the hardcoded range of the "active" sheet in each file in your directory, (folder) to the end of existing data in the "Summary" sheet.

this code is fantastic!

but can someone (John, if you're around) tell me how to change these lines so it will paste special values?

' Copy range to Destination, copies to end of data on Summary page.
Range("A2:O64").Copy _
Destination:=basebook.Sheets("Summary").Range("A" & basebook.Sheets("Summary").Range("A65536").End(xlUp).Row + 1)

 

[able83]

it's ok. figured it out. i was doing something dumb.

great code. thanks John

 

[TGM]

Hello,

I have been trying to use the code in this post but keep getting the following error:

Run-time error '-2147417848(80010108)'
Automation error
The object invoked has discontinued from its clients

on this line:

    mybook.Close SaveChanges:=False

I am trying to do a similar thing to what the original poster wanted.

I think that the macros in the workbooks I am trying to loop through may be interfering but I do not know why or how as I have set them to open in read only mode.

Please can someone point me in the right direction.

Many thanks,

Scott

 

[Datsmart]

I would suggest opening a new thread and including exactly what you want to do, your questions and all your code.