Import from multiple workbook to single SHEET
Solved/Closed
Nitin
-
Sep 16, 2010 at 12:52 AM
samirelsabagh Posts 4 Registration date Wednesday April 17, 2013 Status Member Last seen April 21, 2013 - Apr 17, 2013 at 08:26 PM
samirelsabagh Posts 4 Registration date Wednesday April 17, 2013 Status Member Last seen April 21, 2013 - Apr 17, 2013 at 08:26 PM
Related:
- Import from multiple workbook to single SHEET
- How to import contacts from sim - Guide
- Which key is used to make multiple line in a single cell - Guide
- How to import data from one excel sheet to another automatically - Guide
- Little alchemy cheat sheet - Guide
- Google sheet right to left - Guide
4 responses
rizvisa1
Posts
4478
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
May 5, 2022
766
Sep 19, 2010 at 08:14 AM
Sep 19, 2010 at 08:14 AM
Most easy solution would be that once all sheets are created, just have one more macro that will copy and paste the data to a master sheet.
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
rizvisa1
Posts
4478
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
May 5, 2022
766
Sep 20, 2010 at 05:36 AM
Sep 20, 2010 at 05:36 AM
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
samirelsabagh
Posts
4
Registration date
Wednesday April 17, 2013
Status
Member
Last seen
April 21, 2013
Apr 17, 2013 at 08:26 PM
Apr 17, 2013 at 08:26 PM
I need a code to import a specific group of cells (not a range) from several workbooks in the same folder.
