Excel VBA Macro to Import sheet from all file in folder and then merge first two columns in to master sheet

Hi Every one.

It is big pain for MIS guys to import data from many files to the master file and manipulate the same. Below macro will import all Only Active sheet from each file into the master workbook, after impoting sheets, it will copy first two columns and keep last 10 character from it.

Option Explicit

Sub Merge_All_Excel()



Application.ScreenUpdating = False

Application.DisplayAlerts = False



Dim sn(9999) As String

Dim xDir$, fName As String

Dim sheetname As String

Dim master As Workbook, import As Worksheet, file2 As Workbook

Dim r As Long, i As Long

Dim xt As String

Dim lr As Long

Set master = ThisWorkbook

  

With Application.FileDialog(msoFileDialogFolderPicker)

     .InitialFileName = Application.ThisWorkbook.Path & "\"

     .Title = "Please select a folder containing files"

     .Show

If .SelectedItems.Count <> 0 Then

   xDir$ = .SelectedItems(1) & "\"

End If

End With

  

fName = Dir(xDir$)



    r = 1

    Do While Len(fName) > 0

        If UCase(Split(fName, ".")(UBound(Split(fName, ".")))) = "CSV" Or _

        Left(UCase(Split(fName, ".")(UBound(Split(fName, ".")))), 2) = "XL" Then

        sn(r) = fName

        r = r + 1

        End If

        fName = Dir

    Loop



    On Error Resume Next

    For i = 1 To r - 1

        Workbooks.Open xDir$ & sn(i), ReadOnly:=True

        Set file2 = ActiveWorkbook

        Set import = file2.ActiveSheet

        import.Copy After:=master.Sheets(master.Sheets.Count)

        file2.Close False

        master.Sheets(Sheets.Count).Activate

      

        xt = Split(sn(i), ".")(UBound(Split(sn(i), ".")))

        sheetname = Replace(sn(i), "." & xt, "")

        master.ActiveSheet.Name = sheetname

    Next i



Dim shCount As Integer

Dim col As Integer

Dim sh As Worksheet

Dim dRng As Range

Dim cell As Range

Dim LastCell As Range

Dim rng2 As Range



Set sh = Sheets("MASTER")

sh.Activate

sh.Cells.Clear



shCount = Sheets.Count

col = 1

For i = 1 To shCount

If Sheets(i).Name <> "MASTER" Then

Sheets(i).Activate

Set dRng = sh.Cells(1, col)

dRng.Resize(1, 2).Value = Sheets(i).Name

lr = Cells.Find(What:="*", SearchOrder:=xlRows, _

    SearchDirection:=xlPrevious, LookIn:=xlValues).Row

Set dRng = sh.Cells(2, col)

Sheets(i).Range("A1:B" & lr).Copy

sh.Select

dRng.PasteSpecial xlPasteValues

col = col + 2

End If

Next

sh.Activate

Application.CutCopyMode = False

Cells.Columns.AutoFit



Set LastCell = Cells(Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row, Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, LookIn:=xlValues).Column)

Set rng2 = Range(Range("A3"), LastCell)



For Each cell In rng2

If cell.Value <> "" Then

cell.Value = Right(cell.Value, 10)

End If

Next cell



Cells.Columns.AutoFit





Application.ScreenUpdating = True

Application.DisplayAlerts = True



MsgBox "Done", Title:="www.ExcelVbaLab.Com"

Range("A1").Select

End Sub

Do write your feedback & post your excel VBA macro related query on www.ExcelVbaLab.Com

Cheers!!

Tags: #Excel #VBA #Macro to #Import #sheet #from all #files in #folder and then #merge #first two columns into #master #sheet