Import from multiple workbook to single SHEET [Solved/Closed]
Nitin -
Sep 16, 2010 at 12:52 AM - Latest reply: samirelsabagh4
Posts Wednesday April 17, 2013Registration date
April 21, 2013
Last seen
- Apr 17, 2013 at 08:26 PM
Thank for all your wonderfull help all these days,
to cut short, I am looking for a VBAcode, which can import data from multiple Workbook files in a specific folder & accumulate it in a single WORKSHEET, one below,
I have tried below codes, it imports data very well, but it creats separate multiple sheet, whereas, all data should accumulate one below other,
Sub Import()
' Import Macro
' Keyboard Shortcut: Ctrl+Shift+I
Dim FilesToOpen
Dim x As Integer
Dim wkbAll As Workbook
Dim wkbTemp As Workbook
Dim sDelimiter As String
On Error GoTo ErrHandler
Application.ScreenUpdating = False
sDelimiter = "|"
FilesToOpen = Application.GetOpenFilename _
(MultiSelect:=True, Title:="Text Files to Open")
If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "No Files were selected"
GoTo ExitHandler
End If
x = 1
Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
wkbTemp.Sheets(1).Copy
Set wkbAll = ActiveWorkbook
wkbTemp.Close (False)
wkbAll.Worksheets(x).Columns("A:A").TextToColumns _
Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, _
Comma:=False, Space:=False, _
Other:=True, OtherChar:="|"
x = x + 1
While x <= UBound(FilesToOpen)
Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
With wkbAll
wkbTemp.Sheets(1).Move After:=.Sheets(.Sheets.Count)
.Worksheets(x).Columns("A:A").TextToColumns _
Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, _
Comma:=False, Space:=False, _
Other:=True, OtherChar:=sDelimiter
End With
x = x + 1
Wend
ExitHandler:
Application.ScreenUpdating = True
Set wkbAll = Nothing
Set wkbTemp = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub
That true,
What I have done is I have added event to the same macro code to copy all data in "Master Sheet:, It also works, except to 1 small bug :
It Copies data one below other but, for some unknown reason, it skips last line of each database, please note codes below, may be you can suggest some correction, (i was looking for Row copy event, instade of range copy event)
---------------------------------------------------------
Sub Import()
' Import Macro
' Keyboard Shortcut: Ctrl+Shift+I
Dim FilesToOpen
Dim x As Integer
Dim wkbAll As Workbook
Dim wkbTemp As Workbook
Dim sDelimiter As String
On Error GoTo ErrHandler
'Application.ScreenUpdating = False
sDelimiter = "|"
FilesToOpen = Application.GetOpenFilename _
(MultiSelect:=True, Title:="Text Files to Open")
If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "No Files were selected"
GoTo ExitHandler
End If
x = 1
Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
wkbTemp.Sheets(1).Copy
Set wkbAll = ActiveWorkbook
wkbTemp.Close (False)
wkbAll.Worksheets(x).Columns("A:A").TextToColumns _
Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, _
Comma:=False, Space:=False, _
Other:=True, OtherChar:="|"
x = x + 1
While x <= UBound(FilesToOpen)
Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
With wkbAll
wkbTemp.Sheets(1).Move Before:=.Sheets(.Sheets.Count)
.Worksheets(x).Columns("A:A").TextToColumns _
Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, _
Comma:=False, Space:=False, _
Other:=True, OtherChar:=sDelimiter
End With
x = x + 1
Wend
Sheets.Add Before:=Sheets(1) '-- place at begining
ActiveSheet.Name = "MASTER"
Dim sh1 As Integer, lastrow As Long, ws As Worksheet
sh1 = Worksheets("Master").Index 'change to your master sheet name
For Each ws In Worksheets
lastrow = Worksheets(sh1).UsedRange.Rows.Count
If ws.Index <> sh1 Then
With ws
.Activate
'.Range("A2", .UsedRange.End(xlToRight).End(xlDown).Address).Copy
.Range("A1").Select
.Range(Selection, Selection.End(xlToRight)).Select
.Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
End With
Worksheets(sh1).Cells(lastrow + 2, 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
Next ws
Worksheets(sh1).Activate
Application.ScreenUpdating = True
ExitHandler:
Set wkbAll = Nothing
Set wkbTemp = Nothing
Exit Sub
Try this. This presumes you want to copy from first row to last row of each sheet
Dim sh1 As Integer, lastrow As Long, ws As Worksheet
Dim Cell As Range
Dim iLastCol As Integer
Dim lLastRow As Long
Sheets.Add Before:=Sheets(1) '-- place at begining
ActiveSheet.Name = "MASTER"
sh1 = Worksheets("Master").Index 'change to your master sheet name
For Each ws In Worksheets
lastrow = Worksheets(sh1).UsedRange.Rows.Count
If ws.Index <> sh1 Then
With ws
.Activate
Set Cell = Cells.Find("*", Cells(1, 1), , , xlByRows, xlPrevious)
If Not Cell Is Nothing Then
lLastRow = Cell.Row
'If lLastRow < 2 Then lLastRow = 2
Set Cell = Cells.Find("*", Cells(1, 1), , , xlByColumns, xlPrevious)
iLastCol = Cells.Column
Range(Cells(1, 1), Cells(lLastRow, iLastCol)).Copy
Worksheets(sh1).Select
Cells(lastrow + 2, 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
End With
End If
Next
Worksheets(sh1).Activate
Set Cell = Nothing
Application.ScreenUpdating = True
