• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 422
  • Last Modified:

Excel 2010 - makro that combines data from mutiple worksheets

Hi,

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
    
      ActiveSheet.Range("A4:AU65536").Clear
            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
            Next
            
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
0
wfskmoney
Asked:
wfskmoney
  • 2
1 Solution
 
suvmitraCommented:
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)
    Range(u).Copy
    y = ActiveWorkbook.Name
    Workbooks(X).Activate
    ws.Range("A" & ws.Cells(65536, "a").End(xlUp).Row + 1).PasteSpecial xlPasteAll
    Workbooks(y).Close ([vbNo])
f = Dir
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
ws.Select
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)
    Else
        GetDirectory = ""
    End If

End Function

Open in new window

0
 
suvmitraCommented:
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.
0

Featured Post

How to Use the Help Bell

Need to boost the visibility of your question for solutions? Use the Experts Exchange Help Bell to confirm priority levels and contact subject-matter experts for question attention.  Check out this how-to article for more information.

  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now