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?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

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


Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
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).


It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.