Pull data from multiple workbooks to populate new workbook

[Mikeymike_W]

Hi,

I want to create a spreadsheet that will pull data from a form that my clients use.

There will be many of these forms and each one will have a slightly different file name but be stored in the same folder (C:\Users\MWa\Desktop\VBA Test\filename)

I want to copy the exact same cells from sheet 3 in the form to the new spreadsheet.

There will be many of these forms within the folder at one time. Can the code read all of these and add a new line in the spreadsheet for each form with one click?

I realise I'm asking a lot but I'm hoping the excel gods are watching over me

Many thanks in advance,

Mike

 

[Fluff]

Give this a go.

Sub ConsolidateWbks()

    Dim Pth As String
    Dim MstSht As Worksheet
    Dim fname As String
    
Application.ScreenUpdating = False

    Pth = "C:\Users\MWa\Desktop\VBA Test\"
    Set MstSht = ThisWorkbook.Sheets("[COLOR=#ff0000]Test1[/COLOR]")
    fname = Dir(Pth & "*xls*")
    Do While Len(fname) > 0
        Workbooks.Open (Pth & fname)
        With Workbooks(fname)
            .Sheets("[COLOR=#ff0000]Sheet3[/COLOR]").Range("[COLOR=#ff0000]A1:F5[/COLOR]").copy MstSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
            .Close , False
        End With
        fname = Dir
    Loop

End Sub

You'll need to change the sheet names & range to suit.

 

[Mikeymike_W]

Hi Fluff,

Thanks for your help, the code youprovided works well but I'm encountering some unforeseen issues.

The cells that are being copied contain a formula to populate it with a value. The code you provided seems to copy the formula in the cell rather than the value in the cell, is there a way around this?

Thanks for your help

Mike

 

[Mikeymike_W]

I also meant to ask one other thing.

Is there a way to suppress the save changes prompt?
At the moment it asks me for each workbook open which is quite frustrating.

I tried adding, ThisWorkbook.Saved = True to the code but it didn't seem to do anything.

Thanks again,

Mike

 

[Mikeymike_W]

Hi,

I've managed to workout how to copy the value of the cell by altering the code as follows:

.Sheets("Global FACT").Range("B2").Copy
MstSht.Range("E" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

I still need help with the save prompt though

 

[Fluff]

As you are only copying 1 cell you can use this

            MstSht.Range("E" & Rows.Count).End(xlUp).Offset(1).Value = .Sheets("Global FACT").Range("B2").Value
            Application.DisplayAlerts = False
            .Close , False
            Application.DisplayAlerts = True

It avoids copying data to the clipboard & back again. This should also prevent the prompt from coming up.

 

[Mikeymike_W]

Yup this works a charm thanks

One new issue though is that I don't just have one cell, I have about 30 cells that I need to copy. I thought I could just keep repeating the code and change the range but I quickly realised that it adds a new line for each cell that it copies... would you know how to adjust the code to allow for multiple cells in various locations?

Thanks again,

Mike

 

[Fluff]

What cells do you want to copy & where do you want them copied to?

 

[Mikeymike_W]

There are two sheets within the one workbook I want to copy the cells from.
3 cells on a sheet named "CRF" the cells are C12, C16 and G4.
The other cells are on a sheet named "Global" and the range is B2:B35 as well as cells C36.

I want all of these cells copied to a new row each cell assigned to a different column within that row... this will be within a separate workbook where the code will run from.

Thanks again,

Mike

 

[Fluff]

Ok, try this

Sub ConsolidateWbks()

    Dim Pth As String
    Dim MstSht As Worksheet
    Dim fname As String
    Dim Rng As Range
    
Application.ScreenUpdating = False

    Pth = "C:\Users\MWa\Desktop\VBA Test\"
    Set MstSht = ThisWorkbook.Sheets("Test1")
    fname = Dir(Pth & "*xls*")
    Do While Len(fname) > 0
        Workbooks.Open (Pth & fname)
        With Workbooks(fname)
            Set Rng = MstSht.Range("E" & Rows.Count).End(xlUp).Offset(1)
            Rng.Resize(, 34).Value = Application.Transpose(.Sheets("Global FACT").Range("B2:B35").Value)
            Rng.Offset(, 35).Value = .Sheets("Global FACT").Range("C36").Value
            Rng.Offset(, 36).Value = .Sheets("CRF").Range("C12").Value
            Rng.Offset(, 37).Value = .Sheets("CRF").Range("C16").Value
            Rng.Offset(, 38).Value = .Sheets("CRF").Range("G4").Value
            Application.DisplayAlerts = False
            .Close , False
            Application.DisplayAlerts = True
        End With
        fname = Dir
    Loop

End Sub