Friday, March 25, 2016

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"


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


    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



        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")



shCount = Sheets.Count

col = 1

For i = 1 To shCount

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


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


dRng.PasteSpecial xlPasteValues

col = col + 2

End If



Application.CutCopyMode = False


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


Application.ScreenUpdating = True

Application.DisplayAlerts = True

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


End Sub

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


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

No comments:

Post a Comment