Here is the code-
Sub getfilen()
'********************* to get file names in folder
Dim j As Long
Dim fldpath
Dim fld, fil As Object
j = 2
Range("a2").Select
Application.FileDialog(msoFileDialogFolderPicker).Title = "Choose Folder"
Application.FileDialog(msoFileDialogFolderPicker).Show
fldpath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
Set fso = CreateObject("scripting.filesystemobject")
Set fld = fso.getfolder(fldpath)
For Each fil In fld.Files
' will search for excel files only
If UCase(Right(fil.Path, 4)) = UCase(".xls") Or UCase(Right(fil.Path, 5)) = UCase(".xlsx") Then
Cells(j, 1).Value = fil.Path
j = j + 1
End If
Next fil
End Sub
Sub consolidatefromdifferentworkbooks()
'**************************** MERGE DATA ***************************
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ask, ask2, ask3 As Workbook
Dim i, j, ash, ash1 As Long
Dim N, z, r, s, k As Long
Set ask3 = ThisWorkbook
Set ask = Workbooks.Add
ask3.Activate
For j = 2 To ask3.Sheets(1).Range("b65356").End(xlUp).Row
wks = ask3.Sheets(1).Cells(j, 2).Value
ask.Activate
ask.Sheets.Add After:=ask.Sheets(ask.Sheets.Count)
ask.Sheets(ask.Sheets.Count).Name = wks
ask3.Activate
Next j
ask.Activate
ask.Sheets("Sheet1").Delete
ask.Sheets("Sheet2").Delete
ask.Sheets("Sheet3").Delete
r = ThisWorkbook.Sheets(1).Range("A65356").End(xlUp).Row
For i = 2 To r
For ash = 2 To ThisWorkbook.Sheets(1).Range("b65356").End(xlUp).Row
ask3.Activate
Workbooks.Open Filename:=Sheets(1).Range("a" & i).Value
Set ask2 = ActiveWorkbook
For ash1 = 1 To ask2.Worksheets.Count
If UCase(ask2.Sheets(ash1).Name) = UCase(ThisWorkbook.Sheets(1).Range(" b" & ash).Value) Then
ask2.Sheets(ash1).Select
N = Range("A1").SpecialCells(xlLastCell).Row
If N >= 2 Then
Rows("1:" & N).Select
Selection.Copy
ask.Activate
ask.Sheets(ThisWorkbook.Sheets(1).Range(" b" & ash).Value).Activate
ActiveSheet.Cells(Range("A1").SpecialCells(xlLastCell).Row + 1, 1).Select
ActiveSheet.Paste
End If
Exit For
End If
Next ash1
Next ash
ask2.Activate
ask2.Close
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Excel Macro File http://www.filefactory.com/file/cda5473/n/NEW_merge_from_different_workbooks.xlsm
No comments:
Post a Comment