Import from multiple workbook to single SHEET [Solved/Closed]
Nitin - - Latest reply:
samirelsabagh
- Posts
- 4
- Registration date
- Wednesday April 17, 2013
- Last seen
- April 21, 2013
Related:
- Import from multiple workbook to single sheet
- Paint Shop Pro - Print multiple images on a single sheet. - How-To - Software
- How get the data from multiple sheet to single sheet / on sheet in Excel ✓ - Forum - Windows Vista
- Print multiple files to single pdf - How-To - PDF
- Excel vba create new workbook and copy sheets ✓ - Forum - Excel
- Excel vba create new workbook with one sheet - How-To - Excel
4 replies
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
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub
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
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub
- Posts
- 4475
- Registration date
- Thursday January 28, 2010
- Status
There might be some blank cell in between
Try this. This presumes you want to copy from first row to last row of each sheet
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