VBA Code help

Joined
Nov 21, 2016
Messages
37
Hi All,

I am trying to use VBA for the first time and using some videos to learn but I am having some trouble and thought i'd ask experts here for help.

I have a folder called output data with 50 workbooks in it all with the same data ranges in it.

I would like to consolidate all of this data into one new workbook.

The data ranges I would like to copy are A1:X24 and A27:40 from each workbook and put into a table in a new workbook.

Would anyone be able to help me with this please?

Thank you
 

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
Hi Afonsomira,

Yes, apologies that should read A27 : X40

The headers of the columns are the same for both sections such as ID, Name, Duration,

However i don't need the headers to be copied only the data underneath

Any help would be much appreciated!
 
Upvote 0
Hi Afonsomira

Please don't apologies - your English is great! :)

Yes sorry I seem to have made a second mistake

the ranges I need are A11:X24 and A27: X40

Apologies again, for my mistakes!
 
Upvote 0
No problem! :)

See if this code help you?

VBA Code:
Sub copyPasteAllFiles()

Application.EnableCancelKey = xlDisabled
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False

Dim folderPath As String
Dim Filename As String
Dim wb As Workbook
Dim Masterwb  As Workbook
Dim lastRow As Long

' set master workbook
Set Masterwb = Workbooks(ThisWorkbook.Name)

folderPath = "C:\Users\eaxmtr1\Desktop\output" 'Put the output folder path

If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
Application.ScreenUpdating = False

Filename = Dir(folderPath & "*.xls*")
Do While Filename <> ""
    Set wb = Workbooks.Open(folderPath & Filename)
    
    lastRow = Masterwb.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
    
    wb.Sheets(1).Range("A11:X24").Copy
    Masterwb.Sheets(1).Range("A" & lastRow + 1).PasteSpecial xlValues
    Application.CutCopyMode = False
    
    lastRow = Masterwb.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
    
    wb.Sheets(1).Range("A27:X40").Copy
    Masterwb.Sheets(1).Range("A" & lastRow + 1).PasteSpecial xlValues
    Application.CutCopyMode = False
    
    wb.Close False

Exit_Loop:
    Set wb = Nothing
    Filename = Dir
Loop

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub
 
Upvote 0
Hi
Try this code might be fast
VBA Code:
Sub import_TY()
    Dim MyFolder As String
    Dim myPath As String
    Dim MyFile As String
    Dim fDialog As FileDialog
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    Dim wbk As Workbook
    Dim a, b As Variant
    Dim i As Integer
    Dim x
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    With fDialog
        .AllowMultiSelect = True
        .Title = "Please select the files"
        .Filters.Clear
        .Filters.Add "All supported files", "*.xlsx"
        .Filters.Add "Text Files", "*.xlsx"
        If .Show = True Then
            Dim fPath As Variant
            i = 1
            ReDim a(1 To .SelectedItems.Count)
            ReDim b(1 To .SelectedItems.Count)
            For Each fPath In .SelectedItems
                Set wbk = Workbooks.Open(Filename:=fPath)
                With wbk
                    a(i) = .Sheets("sheet1").Range("a1:x24").Value
                    b(i) = .Sheets("sheet1").Range("a27:x40").Value
                    i = i + 1
                End With
                wbk.Close savechanges:=False
            Next
        End If
    End With
    x = 1
        With Sheets("sheet1")
       For i = 1 To UBound(a)
            Cells(x, 1).Resize(UBound(a(i), 1), UBound(a(i), 2)) = a(i)
            Cells(x + UBound(a(i), 1), 1).Resize(UBound(b(i), 1), UBound(b(i), 2)) = b(i)
            x = x + UBound(a(i), 1) + UBound(b(i), 1)
        Next
        End With
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Hi Afonsomira, your code worked perfectly for me!

Thank you so much for your help on the matter!

Mohadin, my first sheet for each of the workbook i wanted to copy shares the same name as the workbook itself - could that have been causing an issue with the code you sent through?

Just want to say thank you very much to both of you for your help on the matter!

Kindest,
Novicesportperformer
 
Upvote 0
Mohadin, my first sheet for each of the workbook i wanted to copy shares the same name as the workbook itself - could that have been causing an issue with the code you sent through?
No but you have to select the files not folder
 
Upvote 0

Forum statistics

Threads
1,224,824
Messages
6,181,187
Members
453,020
Latest member
Mohamed Magdi Tawfiq Emam

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top