Previous Topic Next Topic

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
Hi,

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

------------------------------------------------------------------

Please kindly help..
Thanks once again.

4 replies

Answer 1 / 4
rizvisa1
Posts
4479
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
May 5, 2022
 769
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.
0
Answer 2 / 4
Nitin
Sep 20, 2010 at 04:08 AM
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
0
rizvisa1
Posts
4479
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
May 5, 2022
 769
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 

    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
0
Answer 3 / 4
Nitin
Sep 21, 2010 at 04:26 AM
Thanks ...
It works!!
0
Answer 4 / 4
samirelsabagh
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.
0