VB Script to Loop Through Tabs, Copy, Paste Elsewhere

I need a Macro that will loop through a file and copy a range of data from each sheet into a continuous range on a another sheet or workbook.  The attached filed shows what I need.  Really appreciate your help on this.  Thank you.  

A couple of points:
The row range will change each time I run; can't make an absolute reference. Example: 12/31/09 -> 3/31/10, or 2/28/10 -> 03/31/2010.  I'm fine with requiring I define the value of the LBound and UBound ahead of time. The column range will not change.  The starting cell off the range is always B13.  The tab name will need to be pasted for every record/row copied and pasted.  

Many thanks!
Who is Participating?
Would you be OK with something like this, with maybe a little more tweaking?


Sub consolidateSheets()
Dim shtDone As Worksheet, lstRow As Long
Dim wksht As Worksheet, firstSheet As Boolean

Const bolTitles As Boolean = True 'True if sheets have titles, false if they don't
Const strSummary As String = "All" ' update to the name of the consolidated destination
Const strFirstCell As String = "B12" ' update to the name of the consolidated destination
Const bolTab As Boolean = True 'get data from tab name ? True / False
Const strTabTitle As String = "Tab" 'title of column from tab name if bolTab=true
Dim lgTabCol As Long

application.ScreenUpdating = False
application.DisplayAlerts = False

Set shtDone = ActiveWorkbook.Sheets.Add

On Error Resume Next
shtDone.Name = strSummary

If Err.Number <> 0 Then
    shtDone.Name = strSummary
End If

firstSheet = True

For Each wksht In ActiveWorkbook.Sheets
    If wksht.Name = strSummary Then GoTo nxtSht
    Debug.Print wksht.range(wksht.range(strFirstCell), wksht.range(strFirstCell).End(xlDown).End(xlToRight)).Address
    wksht.range(wksht.range(strFirstCell), wksht.range(strFirstCell).End(xlDown).End(xlToRight)).Copy
    lstRow = shtDone.range("A" & Rows.Count).End(xlUp).Row
    shtDone.range("A" & lstRow + 1).Select

    If bolTitles = True And firstSheet = False Then
        Rows(lstRow + 1).Delete
        If bolTab = True And firstSheet = True Then
            lgTabCol = shtDone.Cells(2, Columns.Count).End(xlToLeft).Column + 1
            shtDone.Cells(2, lgTabCol) = strTabTitle
            lstRow = lstRow + 1
        End If
    End If
    If bolTab = True Then
        shtDone.Cells(lstRow + 1, lgTabCol) = wksht.Name
    End If
    firstSheet = False


If bolTab = True Then
    Intersect(ActiveSheet.UsedRange, Columns(lgTabCol)).Offset(1, 0).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
    ActiveSheet.PasteSpecial Paste:=xlPasteValues
    application.CutCopyMode = False
End If

application.DisplayAlerts = True
application.ScreenUpdating = True
End Sub

Open in new window

SpartanValorAuthor Commented:
Wow, I'm very impressed.  This worked first time, straight out of the box, with an idiot (me) implementing it.  I really can't thank you enough.  I have another workbook, different, for which I need to do the same thing.  Once I collect what I need, I will submit a new question.  I'd love it if you took a look since you banged this one out so perfectly.  Thanks so much nutsch!  Best regards,  SV
Glad to help. Thanks for the kind comment.

If you check the constants at the top of my code, you will find that by just changing them slightly, you can apply that code to different workbooks and get the same results.

If you want to post addtl related questions, refer to this original question and I'll get an automatic notification (even though there are a lot of very competent experts at all hours of day and night in the excel zone).


Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.