Senin, 08 Desember 2014

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

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

.

__,_._,___

Tidak ada komentar:

Posting Komentar