Import from multiple workbook to single SHEET
Solved/Closed
Nitin
-
Sep 16, 2010 at 12:52 AM
samirelsabagh
samirelsabagh
- Posts
- 4
- Registration date
- Wednesday April 17, 2013
- Status
- Member
- Last seen
- April 21, 2013
Related:
- Import from multiple workbook to single SHEET
- How get the data from multiple sheet to single sheet / on sheet in Excel ✓ - Forum - Windows Vista
- Creating multiple workbooks from a template and a list of names ✓ - Forum - Excel
- How to duplicate a workbook in google sheets - Guide
- How to import excel data to another excel sheet - Guide
- How to enter multiple lines in single excel cell - Guide
4 replies
rizvisa1
Sep 19, 2010 at 08:14 AM
- Posts
- 4479
- Registration date
- Thursday January 28, 2010
- Status
- Contributor
- Last seen
- May 5, 2022
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
Sep 20, 2010 at 05:36 AM
- Posts
- 4479
- Registration date
- Thursday January 28, 2010
- Status
- Contributor
- Last seen
- May 5, 2022
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
Apr 17, 2013 at 08:26 PM
- Posts
- 4
- Registration date
- Wednesday April 17, 2013
- Status
- Member
- Last seen
- April 21, 2013
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.