VBA Code help

[Novicesportsperformer]

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

 

[afonsomira]

A27:40

Here would be A27: X40?

What are the headers of the columns?

 

[Novicesportsperformer]

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!

 

[afonsomira]

So you can copy only from the second line, since you don't want the headers. Right?

Sorry my English I am learning.

 

[Novicesportsperformer]

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!

 

[afonsomira]

No problem!

See if this code help you?

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

 

[mohadin]

Hi
Try this code might be fast

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

 

[Novicesportsperformer]

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

 

[mohadin]

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