Excel 2010 - makro that combines data from mutiple worksheets

Posted on 2012-09-22
Last Modified: 2012-09-28

I have 3 worksheets and 1 output sheet.
Each worksheet looks like:

var1 | var2 | var3 | varn
   2        3          5       "data"

All worksheets have the same variable structure.

I need a makro that just combines the data of all worksheets into the output sheet. Before combining, it should delete the old content in the output sheet, of course. For each worksheet, data start at the 4th line, 2nd column. Sometimes data in the worksheets is created by formulas. It should only copy data from columns A to AU, not other columns.

What is a smart way to do this? Does someone have an example code?

I tried:
Sub Merge()
    Dim ws As Worksheet
            For Each ws In ActiveWorkbook.Worksheets
                If InStr(1, ws.Name, "sheet") > 0 Then
                        ws.UsedRange.Offset(3, 0).Copy
                        With Range("A65536").End(xlUp).Offset(3, 1)
                            .PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
                            False, Transpose:=False
                            .PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
                            False, Transpose:=False
                        End With

                End If
End Sub

Open in new window

This code has these problems:
1. Copies a fields with empty data
2. Doesnt append the sheets but overwrites them
Question by:wfskmoney
    LVL 9

    Accepted Solution

    Only change the Destination Sheet, Range to Copy etc.

    Sub Process_XL_Files(Optional str As String)
    On Error Resume Next
    Dim f As String
    Dim i As Long, X As String, y As String
    Dim ws As Worksheet
    flPath = GetDirectory()
    'flPath = Application.InputBox("Please provide the Folder Path", Type:=2)
    If flPath = "" Then
            MsgBox "No folder was selected.  Procedure aborted.", vbExclamation, "XL Power Tool"
            Exit Sub
    End If
    'u = Application.InputBox("Please provide the Range To Copy", Type:=2)
    'If u = "" Then Exit Sub
    'If u = False Then Exit Sub
    'If flPath = "" Then Exit Sub
    'If flPath = False Then Exit Sub
    X = ActiveWorkbook.Name
    'wsName = Application.InputBox("Please provide the Name of the Destination Sheet", Type:=2)
    'If wsName = "" Then Exit Sub
    'If wsName = False Then Exit Sub
    'Set ws = Sheets("Data")
    Sheets(wsName).Visible = True
    Set ws = Sheets(wsName)
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    f = Dir(flPath & "\" & "*.xls*")
    Do Until f = ""
        Workbooks.Open (flPath & "\" & f)
        y = ActiveWorkbook.Name
        ws.Range("A" & ws.Cells(65536, "a").End(xlUp).Row + 1).PasteSpecial xlPasteAll
        Workbooks(y).Close ([vbNo])
    f = Dir
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    f = vbNullString
    flPath = vbNullString
    X = vbNullString
    y = vbNullString
    u = vbNullString
    Set ws = Nothing
    wsName = vbNullString
    End Sub
    Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
        "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
    Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
        "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
    Public Type BROWSEINFO
      hOwner As Long
      pidlRoot As Long
      pszDisplayName As String
      lpszTitle As String
      ulFlags As Long
      lpfn As Long
      lParam As Long
      iImage As Long
    End Type
    Private Function GetDirectory(Optional msg) As String
        Dim bInfo As BROWSEINFO
        Dim path As String
        Dim r As Long
        Dim X As Long
        Dim pos As Integer
    ' Root folder = Desktop
        bInfo.pidlRoot = 0&
    ' Title in the dialog
        If IsMissing(msg) Then bInfo.lpszTitle = "Select a folder." Else bInfo.lpszTitle = msg
    ' Type of directory to return
        bInfo.ulFlags = &H1
    ' Display the dialog
        X = SHBrowseForFolder(bInfo)
    ' Parse the result
        path = Space$(512)
        r = SHGetPathFromIDList(ByVal X, ByVal path)
        If r Then
            pos = InStr(path, Chr$(0))
            GetDirectory = Left(path, pos - 1)
            GetDirectory = ""
        End If
    End Function

    Open in new window

    LVL 9

    Expert Comment

    This code basically combine all workbooks data from a particular folder. It selects a particular sheet from all the workbooks and a particular range from the worksheet.

    So If you want to copy and append Range("A1:D40") from Sheet1 of all the workbooks in a particular folder you can use it.

    Featured Post

    How your wiki can always stay up-to-date

    Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
    - Increase transparency
    - Onboard new hires faster
    - Access from mobile/offline

    Join & Write a Comment

    Convert between Excel file formats (.XLS, .XLSX, .XLSM) with/without macro option David Miller (dlmille) Intro Over this past Fall, I've had the opportunity to see several similar requests and have developed a couple related solutions associate…
    Deploying a Microsoft Access application in a Citrix environment is not difficult but takes a few steps. However, Citrix system people are often of little help, as they typically know next to nothing about Access. The script provided here will take …
    The viewer will learn how to simulate a series of sales calls dependent on a single skill level and learn how to simulate a series of sales calls dependent on two skill levels. Simulating Independent Sales Calls: Enter .75 into cell C2 – “skill leve…
    This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.

    755 members asked questions and received personalized solutions in the past 7 days.

    Join the community of 500,000 technology professionals and ask your questions.

    Join & Ask a Question

    Need Help in Real-Time?

    Connect with top rated Experts

    20 Experts available now in Live!

    Get 1:1 Help Now