Merging data from dynamic range of worksheets

[Dinhosa]

Hi all, apologies for what may well be a simple request looking for some help in creating a macro that is beyond my capabilities!

I have a file with multiple tabs, one of which is an "Output" tab and there are many others (more than 50) that contain data with identical column names. There are other tabs in the file as well but these are not relevant to this exercise.

In my 50ish data tabs I have 5 columns of data each with a different number of populated rows. I'd like to take all the data from columns A & C from each tab and merge them together in my Output tab as column A & B. Nothing fancy, just one set of data on top of the other. Additionally I'd like to add a third column which is populated with the worksheet name from which that row of data came from. The number of worksheets included in this range will change from time to time so ideally I'd like to be able to have a list that I can add/subtract tab names for the macro to reference.

I did try a Power Query option by appending the data but due to the amount of data/tabs it was taking far too long to refresh so I'm hoping VBA will be the solution. Thanks in advance for any advice.

 

[John_w]

Try this macro, with the sheets whose columns you want to merge in the sheetNames array.

Public Sub Merge_Columns()

    Dim sheetNames As Variant, sheetName As Variant
    Dim destCells As Range, destCellsName As Range, wsStartRow As Long
    Dim lastRow As Long
    
    sheetNames = Array("Sheet1", "Sheet2", "Sheet3")
    
    Application.ScreenUpdating = False
    
    With ThisWorkbook.Worksheets("Output")
        .Cells.Clear
        Set destCells = .Range("A1:B1")
        .Range("C1").Value = "Sheet Name"
        Set destCellsName = .Range("C2")
        wsStartRow = 1  'copy column headings
    End With
    
    For Each sheetName In sheetNames
        With ThisWorkbook.Worksheets(sheetName)
            lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
            Union(.Range("A" & wsStartRow & ":A" & lastRow), .Range("C" & wsStartRow & ":C" & lastRow)).Copy destCells
            destCellsName.Resize(lastRow - 1, 1).Value = .Name
            Set destCells = destCells.Offset(lastRow - wsStartRow + 1)
            Set destCellsName = destCellsName.Offset(lastRow - 1)
            wsStartRow = 2 'omit column headings
        End With
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "Done"
    
End Sub

 

[Dinhosa]

Six months too late but clearing up open tabs on my phone I realised I hadn't thanked you for this John, so thank you, it really was helpful.

Apologies to everyone else reading this because I bumped it, I couldn't find a way to message John privately on the forum