Re: [ExcelVBA] macro to aggregate worksheets from many workbooks

 

Many thanks to Dan & David for thier sterling efforts

Enjoy this! 

' With many thanks to Dan Boote (Atkins Acoustician) and David Grugeon (Ms_excel Yahoogroup)

Sub worksheet_combiner()

Dim wbk As Workbook

Dim wsht As Worksheet

Dim tr As Long

Dim sr As Long

Dim ts As Worksheet

Dim ta As Workbook

Dim startrow As Long

Dim endrow As Long

Dim wbcount As Integer

Dim wbcur As Integer

Dim wscur As Integer

Dim wstally As Long

Dim dirpath As String

Dim endcolumn As Long

Dim File As String

wstally = 0

With Application.FileDialog(msoFileDialogFolderPicker)

        .InitialFileName = "D:\"

        .AllowMultiSelect = False

        .Show

        On Error Resume Next

        dirpath = .SelectedItems(1)

        Err.Clear

        On Error GoTo 0

End With

On Error Resume Next

Set ta = ActiveWorkbook

Set ts = ActiveWorkbook.Sheets(1)

Application.ScreenUpdating = False

    File = Dir(dirpath & "\" & "*.xl*", vbNormal)

    wbcount = 0

    wbcur = 0

    Do While File <> ""

        wbcount = wbcount + 1

        File = Dir()

    Loop

    File = Dir(dirpath & "\" & "*.xl*", vbNormal)

    While (File <> "")

        Set wbk = Workbooks.Open(Filename:=dirpath & "\" & File)

        wbcur = wbcur + 1

        wscur = 0

        For Each wsht In wbk.Worksheets

            wscur = wscur + 1

            wstally = wstally + 1

            Application.StatusBar = "Processing Workbook " & wbcur & " of " & wbcount & ", Worksheet " & wscur & " of " & wbk.Worksheets.Count

            If Range("1:1").Find("*", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column >= 1 Then

                startrow = 1

            Else

                startrow = Cells.Find("*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlNext).Row

            End If

            endrow = Cells.Find("*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

            endcolumn = Cells.Find("*", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

            tr = Workbooks(ta.Name).Sheets(ts.Name).Range("C:C").Find("*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1

            If tr = 0 Then tr = 1 Else tr = tr + 1

            wsht.Range("A" & startrow & ":" & Cells(endrow, endcolumn).Address).Copy

            With Workbooks(ta.Name).Sheets(ts.Name)

                .Range("C" & tr).PasteSpecial Paste:=xlValues

                .Range("A" & tr) = wbk.Name

                .Range("B" & tr) = wsht.Name

                .Range("A" & tr & ":B" & tr).Copy

                .Range("A" & tr & ":B" & .Range("C:C").Find("*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row).PasteSpecial Paste:=xlValues

            End With

        Next wsht

        wbk.Close

        File = Dir

    Wend

    Application.StatusBar = False

    Application.ScreenUpdating = True

    MsgBox (wstally & " Worksheets from " & wbcount & " Workbooks have been added." & vbNewLine & "Please now save the workbook.")

End Sub

On 1 December 2014 at 11:27, David Grugeon yahoo@grugeon.com.au [ExcelVBA] <ExcelVBA@yahoogroups.com> wrote:

I think it would be as follows but I have not tested it so copy the whole directory before trying it.

You will need to open a new workbook and paste this into a module, make a few changes to the parameters and then run it.

Option Explicit

Sub fred()

Dim wbk As Workbook

Dim wsht As Worksheet

Dim tr As Long

Dim sr As Long

Dim ts As Worksheet

Dim startrow As Long

Dim endrow As Long

Dim dirpath As String

Dim endcolumn As String

Dim File As String

startrow = 1 'set these for the start and end of the source range

endrow = 500

endcolumn = "K"

dirpath = "C:\data\sourcefiles\" ' set this for your directory

tr = 1 ' where the list starts in the target wbk

Set ts = ThisWorkbook.Sheets(1)

For Each File In fso.directory(dirpath)

File = Dir(dirpath & "*")

    While (File <> "")

        Workbooks.Open File

        Set wbk = ActiveWorkbook

      For Each wsht In wbk(Worksheets)

        For sr = startrow To endrow

            ts.Cells(tr, 1) = wbk.Name

            ts.Cells(tr, 2) = wsht.Name

           wsht.Range("A" & sr, encolumn & sr).Copy ts.Name & "C" & tr

           tr = tr + 1

         Next sr

       next wsht

     File = Dir

    Wend

End Sub

Regards

David Grugeon

Regards

David Grugeon

On 1 December 2014 at 18:19, Dr John C Bullas john.bullas@gmail.com [ExcelVBA] <ExcelVBA@yahoogroups.com> wrote:

Anyone point me towards a macro to drag all the worksheets from a
number of workbooks in a directory sequentially into a single
worksheet with the source filename and source sheet name in the first
two columns

the data from the sheet would then be inserted line by line with the
same prefix column

the range of data to be grabbed can be fixed in terms of a range

I am trying to aggregate a large number of sheets within a large
number of workbooks where the originators have kindly produced
sequential blocks of data split between worksheets using what should
have been column data as the tab name!!!

Argh!

Many thanks

Dr B

--



===========================
http://uk.linkedin.com/in/drjohnbullas


--

------------------------------------
Posted by: Dr John C Bullas <john.bullas@gmail.com>
------------------------------------

----------------------------------
Be sure to check out TechTrax Ezine for many, free Excel VBA articles! Go here: http://www.mousetrax.com/techtrax to enter the ezine, then search the ARCHIVES for EXCEL VBA.

----------------------------------
Visit our ExcelVBA group home page for more info and support files:
http://groups.yahoo.com/group/ExcelVBA

----------------------------------
More free tutorials and resources available at:
http://www.mousetrax.com

----------------------------------
------------------------------------

Yahoo Groups Links

<*> To visit your group on the web, go to:
    http://groups.yahoo.com/group/ExcelVBA/

<*> Your email settings:
    Individual Email | Traditional

<*> To change settings online go to:
    http://groups.yahoo.com/group/ExcelVBA/join
    (Yahoo! ID required)

<*> To change settings via email:
    ExcelVBA-digest@yahoogroups.com
    ExcelVBA-fullfeatured@yahoogroups.com

<*> To unsubscribe from this group, send an email to:
    ExcelVBA-unsubscribe@yahoogroups.com

<*> Your use of Yahoo Groups is subject to:
    https://info.yahoo.com/legal/us/yahoo/utos/terms/

--

===========================
http://uk.linkedin.com/in/drjohnbullas

__._,_.___

---

Posted by: Dr John C Bullas <john.bullas@gmail.com>

---

Reply via web post

•

Reply to sender

•

Reply to group

•

Start a New Topic

•

Messages in this topic (3)

----------------------------------
Be sure to check out TechTrax Ezine for many, free Excel VBA articles! Go here: http://www.mousetrax.com/techtrax to enter the ezine, then search the ARCHIVES for EXCEL VBA.

----------------------------------
Visit our ExcelVBA group home page for more info and support files:
http://groups.yahoo.com/group/ExcelVBA

----------------------------------
More free tutorials and resources available at:
http://www.mousetrax.com

----------------------------------

Visit Your Group

• New Members 2

• Privacy • Unsubscribe • Terms of Use

.

__,_._,___