Skip to main content

Code to combine data Files in one sheet in excel


 Option Explicit  
 '32-bit API declarations  
 'Test the code:  
 'Click Tools --> Macro --> Macros...  
 'Select CombineFiles and press Run.  
 Declare Function SHGetPathFromIDList Lib "shell32.dll" _  
 Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal _  
 pszpath As String) As Long  
 Declare Function SHBrowseForFolder Lib "shell32.dll" _  
 Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) _  
 As Long  
 Public Type BrowseInfo  
 hOwner As Long  
 pIDLRoot As Long  
 pszDisplayName As String  
 lpszTitle As String  
 ulFlags As Long  
 lpfn As Long  
 lParam As Long  
 iImage As Long  
 End Type  
 Function GetDirectory(Optional msg) As String  
 On Error Resume Next  
 Dim bInfo As BrowseInfo  
 Dim path As String  
 Dim r As Long, x As Long, pos As Integer  
 'Root folder = Desktop  
 bInfo.pIDLRoot = 0&  
 'Title in the dialog  
 If IsMissing(msg) Then  
 bInfo.lpszTitle = "Please select the folder of the excel files to copy."  
 Else  
 bInfo.lpszTitle = msg  
 End If  
 'Type of directory to return  
 bInfo.ulFlags = &H1  
 'Display the dialog  
 x = SHBrowseForFolder(bInfo)  
 'Parse the result  
 path = Space$(512)  
 r = SHGetPathFromIDList(ByVal x, ByVal path)  
 If r Then  
 pos = InStr(path, Chr$(0))  
 GetDirectory = Left(path, pos - 1)  
 Else  
 GetDirectory = ""  
 End If  
 End Function  
 Sub CombineFiles()  
 Dim path As String  
 Dim Filename As String  
 Dim LastCell As Range  
 Dim WKB As Workbook  
 Dim WS As Worksheet  
 Dim ThisWB As String  
 ThisWB = ThisWorkbook.Name  
 Application.EnableEvents = False  
 Application.ScreenUpdating = False  
 path = GetDirectory  
 Filename = Dir(path & "\*.xls", vbNormal)  
 Do Until Filename = ""  
 If Filename <> ThisWB Then  
 'If InStr(Filename, "xlsx") Then  
 'renamexlsx path, Filename  
 'Else  
 Set WKB = Workbooks.Open(Filename:=path & "\" & Filename)  
 For Each WS In WKB.Worksheets  
 'change File Name Here [ V ]  
 'If InStr(WS.Name, strflnmstr) Then  
 'If WS.Name = "strflnmstr" Then  
 If WS.Name <> "" Then  
 Application.DisplayAlerts = False  
 On Error Resume Next  
 Set LastCell = WS.Cells.SpecialCells(xlCellTypeLastCell)  
 WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)  
 On Error GoTo 0  
 Application.DisplayAlerts = True  
 End If  
 Next WS  
 WKB.Close False  
 'End If  
 End If  
 Filename = Dir()  
 Loop  
 Application.EnableEvents = True  
 Application.ScreenUpdating = True  
 Set WKB = Nothing  
 Set LastCell = Nothing  
 End Sub  
 Public Sub renamexlsx()  
 Dim path As String  
 Dim Filename As String  
 path = GetDirectory  
 Filename = Dir(path & "\*.*", vbNormal)  
 Do Until Filename = ""  
 If InStr(Filename, "xlsx") Then  
 ChDir path & "\"  
 Dim strflnm As String  
 strflnm = Mid(Filename, 1, Len(Filename) - 1)  
 Application.DisplayAlerts = False  
 Workbooks.Open Filename:=path & "\" & Filename  
 ActiveWorkbook.SaveAs Filename:=path & "\" & strflnm _  
 , FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _  
 ReadOnlyRecommended:=False, CreateBackup:=False  
 ActiveWorkbook.Close Filename:=path & "\" & strflnm  
 Application.DisplayAlerts = True  
 End If  
 Filename = Dir()  
 Loop  
 End Sub  
 Option Explicit  
 'Copy from row 2 till the last row with data  
 '  
 'Note: This example use the function LastRow  
 '  
 'In example 1 you can see that you can copy all cells on a worksheet with this line:  
 'Set CopyRng = sh.UsedRange  
 '  
 'But what if we do not want to copy the same header row each time.  
 'The example below will copy from row 2 till the last row with data on each sheet  
 '  
 'Change the start row in the macro if you want to start in a different row.  
 '  
 ''Fill in the start row  
 'StartRow = 2  
 'When you run one of the examples it will first delete the summary worksheet  
 'named RDBMergeSheet if it exists and then adds a new one to the workbook.  
 'This ensures that the data is always up to date after you run the code.  
 '*****READ THE TIPS on the website****  
 Sub CopyDataWithoutHeaders()  
 Dim sh As Worksheet  
 Dim DestSh As Worksheet  
 Dim BlankSh As Worksheet  
 Dim Last As Long  
 Dim shLast As Long  
 Dim CopyRng As Range  
 Dim StartRow As Long  
 Dim strsheetname As String  
 Dim Flag As Boolean  
 Dim str As String  
 Dim Runagain As Integer  
 strsheetname = ""  
 Runagain = 0  
 With Application  
 .ScreenUpdating = False  
 .EnableEvents = False  
 End With  
 For Each sh In ActiveWorkbook.Worksheets  
 Runagain = Runagain + 1  
 Next  
 'Delete the sheet "_Merge" if it exist  
 'For Each sh In ActiveWorkbook.Worksheets  
 'If InStr(sh.Name, "_Merge") Or InStr(sh.Name, "Blank") Then  
 ' Application.DisplayAlerts = False  
 ' On Error Resume Next  
 ' ActiveWorkbook.Worksheets(sh.Name).Delete  
 ' On Error GoTo 0  
 ' Application.DisplayAlerts = True  
 'End If  
 'Next  
 'Add a worksheet with the name "Blank"  
 Application.DisplayAlerts = False  
 On Error Resume Next  
 ActiveWorkbook.Worksheets("Blank").Delete  
 On Error GoTo 0  
 Application.DisplayAlerts = True  
 Set BlankSh = ActiveWorkbook.Worksheets.Add  
 BlankSh.Name = "Blank"  
 'Fill in the start row  
 'StartRow = 2  
 'loop through all worksheets and copy the data to the DestSh  
 While Runagain > 0  
 For Each sh In ActiveWorkbook.Worksheets  
 Flag = False  
 If sh.Name = "Blank" Or InStr(sh.Name, "Merge") Then  
 Flag = False  
 ElseIf strsheetname = "" Then  
 strsheetname = sh.Name  
 Set DestSh = ActiveWorkbook.Worksheets.Add  
 Dim strdsnamestr As String  
 If Len(strsheetname) > 24 Then  
 strsheetname = Mid(strsheetname, 1, 24)  
 End If  
 DestSh.Name = strsheetname & "_Merge"  
 Flag = True  
 StartRow = 1  
 Else  
 If InStr(sh.Name, strsheetname) Then  
 Flag = True  
 StartRow = 2  
 End If  
 End If  
 If Flag Then  
 'Loop through all worksheets except the RDBMerge worksheet and the  
 'Information worksheet, you can ad more sheets to the array if you want.  
 If IsError(Application.Match(sh.Name, _  
 Array(DestSh.Name, "Information"), 0)) Then  
 'Find the last row with data on the DestSh and sh  
 Last = LastRow(DestSh)  
 shLast = LastRow(sh)  
 'If sh is not empty and if the last row >= StartRow copy the CopyRng  
 If shLast > 0 And shLast >= StartRow Then  
 'Set the range that you want to copy  
 Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))  
 'Test if there enough rows in the DestSh to copy all the data  
 If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then  
 MsgBox "There are not enough rows in the Destsh"  
 GoTo ExitTheSub  
 End If  
 'This example copies values/formats, if you only want to copy the  
 'values or want to copy everything look below example 1 on this page  
 CopyRng.Copy  
 With DestSh.Cells(Last + 1, "A")  
 .PasteSpecial xlPasteValues  
 .PasteSpecial xlPasteFormats  
 Application.CutCopyMode = False  
 End With  
 End If  
 End If  
 Application.DisplayAlerts = False  
 On Error Resume Next  
 ActiveWorkbook.Worksheets(sh.Name).Delete  
 On Error GoTo 0  
 Application.DisplayAlerts = True  
 End If  
 Next  
 Runagain = 0  
 For Each sh In ActiveWorkbook.Worksheets  
 If sh.Name = "Blank" Or InStr(sh.Name, "Merge") Then  
 Else  
 Runagain = Runagain + 1  
 End If  
 Next  
 strsheetname = ""  
 Wend  
 Application.DisplayAlerts = False  
 On Error Resume Next  
 ActiveWorkbook.Worksheets("Blank").Delete  
 On Error GoTo 0  
 Application.DisplayAlerts = True  
 ExitTheSub:  
 Application.GoTo DestSh.Cells(1)  
 'AutoFit the column width in the DestSh sheet  
 DestSh.Columns.AutoFit  
 With Application  
 .ScreenUpdating = True  
 .EnableEvents = True  
 End With  
 End Sub  
 Option Explicit  
 'Note: This example use the function LastRow  
 'This example copy the range A2:G2 from each worksheet.  
 '  
 'Change the range here  
 '  
 ''Fill in the range that you want to copy  
 'Set CopyRng = sh.Range("A2:G2")  
 'When you run one of the examples it will first delete the summary worksheet  
 'named RDBMergeSheet if it exists and then adds a new one to the workbook.  
 'This ensures that the data is always up to date after you run the code.  
 '*****READ THE TIPS on the website****  
 Sub CopyRangeFromMultiWorksheets()  
 Dim sh As Worksheet  
 Dim DestSh As Worksheet  
 Dim Last As Long  
 Dim CopyRng As Range  
 With Application  
 .ScreenUpdating = False  
 .EnableEvents = False  
 End With  
 'Delete the sheet "RDBMergeSheet" if it exist  
 Application.DisplayAlerts = False  
 On Error Resume Next  
 ActiveWorkbook.Worksheets("RDBMergeSheet").Delete  
 On Error GoTo 0  
 Application.DisplayAlerts = True  
 'Add a worksheet with the name "RDBMergeSheet"  
 Set DestSh = ActiveWorkbook.Worksheets.Add  
 DestSh.Name = "RDBMergeSheet"  
 'loop through all worksheets and copy the data to the DestSh  
 For Each sh In ActiveWorkbook.Worksheets  
 'Loop through all worksheets except the RDBMerge worksheet and the  
 'Information worksheet, you can ad more sheets to the array if you want.  
 If IsError(Application.Match(sh.Name, _  
 Array(DestSh.Name, "Information"), 0)) Then  
 'Find the last row with data on the DestSh  
 Last = LastRow(DestSh)  
 'Fill in the range that you want to copy  
 Set CopyRng = sh.Range("A2:G2")  
 'Test if there enough rows in the DestSh to copy all the data  
 If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then  
 MsgBox "There are not enough rows in the Destsh"  
 GoTo ExitTheSub  
 End If  
 'This example copies values/formats, if you only want to copy the  
 'values or want to copy everything look at the example below this macro  
 CopyRng.Copy  
 With DestSh.Cells(Last + 1, "A")  
 .PasteSpecial xlPasteValues  
 .PasteSpecial xlPasteFormats  
 Application.CutCopyMode = False  
 End With  
 'Optional: This will copy the sheet name in the H column  
 DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name  
 End If  
 Next  
 ExitTheSub:  
 Application.GoTo DestSh.Cells(1)  
 'AutoFit the column width in the DestSh sheet  
 DestSh.Columns.AutoFit  
 With Application  
 .ScreenUpdating = True  
 .EnableEvents = True  
 End With  
 End Sub  
 Sub renamesheets()  
 For Each sh In ActiveWorkbook.Worksheets  
 'If InStr(sh.Name, "_Merge") Then  
 Dim str As String  
 str = sh.Name  
 Dim IndexOf As Integer  
 If InStr(str, "Language Detail") Then  
 ActiveWorkbook.Worksheets(str).Select  
 ActiveWorkbook.Worksheets(str).Name = "Language Detail"  
 ElseIf InStr(str, "Edu") Then  
 ActiveWorkbook.Worksheets(str).Select  
 ActiveWorkbook.Worksheets(str).Name = "Education Qualification Details"  
 ElseIf InStr(str, "Prof") Then  
 ActiveWorkbook.Worksheets(str).Select  
 ActiveWorkbook.Worksheets(str).Name = "Details of Professional Exam"  
 ElseIf InStr(str, "Regi") Then  
 ActiveWorkbook.Worksheets(str).Select  
 ActiveWorkbook.Worksheets(str).Name = "Details of Regional Exam"  
 ElseIf InStr(str, "Depart") Then  
 ActiveWorkbook.Worksheets(str).Select  
 ActiveWorkbook.Worksheets(str).Name = "Details of Department Exam"  
 ElseIf InStr(str, "Train") Then  
 ActiveWorkbook.Worksheets(str).Select  
 ActiveWorkbook.Worksheets(str).Name = "Details of Training"  
 ElseIf InStr(str, "Achi") Then  
 ActiveWorkbook.Worksheets(str).Select  
 ActiveWorkbook.Worksheets(str).Name = "Details of Achievements"  
 ElseIf InStr(str, "Family") Then  
 ActiveWorkbook.Worksheets(str).Select  
 ActiveWorkbook.Worksheets(str).Name = "Details of Family Members"  
 ElseIf InStr(str, "Punish") Then  
 ActiveWorkbook.Worksheets(str).Select  
 ActiveWorkbook.Worksheets(str).Name = "Details of Punishments"  
 ElseIf InStr(str, "Nomi") Then  
 ActiveWorkbook.Worksheets(str).Select  
 ActiveWorkbook.Worksheets(str).Name = "Nomination Details"  
 ElseIf InStr(str, "Prev") Then  
 ActiveWorkbook.Worksheets(str).Select  
 ActiveWorkbook.Worksheets(str).Name = "Previous Service Details"  
 ElseIf InStr(str, "Break") Then  
 ActiveWorkbook.Worksheets(str).Select  
 ActiveWorkbook.Worksheets(str).Name = "Break in service"  
 ElseIf InStr(str, "Inqui") Then  
 ActiveWorkbook.Worksheets(str).Select  
 ActiveWorkbook.Worksheets(str).Name = "Inquiery Detail"  
 ElseIf InStr(str, "Other") Then  
 ActiveWorkbook.Worksheets(str).Select  
 ActiveWorkbook.Worksheets(str).Name = "Other Information"  
 Else  
 End If  
 'End If  
 Next  
 End Sub  
 Option Explicit  
 'Common Functions required for all routines:  
 Function LastRow(sh As Worksheet)  
 On Error Resume Next  
 LastRow = sh.Cells.Find(what:="*", _  
 After:=sh.Range("A1"), _  
 Lookat:=xlPart, _  
 LookIn:=xlFormulas, _  
 SearchOrder:=xlByRows, _  
 SearchDirection:=xlPrevious, _  
 MatchCase:=False).Row  
 On Error GoTo 0  
 End Function  
 Function LastCol(sh As Worksheet)  
 On Error Resume Next  
 LastCol = sh.Cells.Find(what:="*", _  
 After:=sh.Range("A1"), _  
 Lookat:=xlPart, _  
 LookIn:=xlFormulas, _  
 SearchOrder:=xlByColumns, _  
 SearchDirection:=xlPrevious, _  
 MatchCase:=False).Column  
 On Error GoTo 0  
 End Function  
 Sub callselectfile()  
 Call CombineFiles.CombineFiles  
 Call CopyDataWithoutHeaders.CopyDataWithoutHeaders  
 End Sub  
 Option Explicit  
 'Copy a range/column after the last column with data  
 '  
 'Note: This example use the function LastCol  
 '  
 'This example copy column A from each sheet after the last column with data on the DestSh.  
 'I use A:A to copy the whole column but you can also use a range like A1:A10  
 'Use A:C if you want to copy more columns.  
 '  
 'Change it here  
 '  
 ''Fill in the column(s) that you want to copy  
 'Set CopyRng = sh.Range("A:A")  
 '  
 'Remember that Excel 97-2003 have only 256 columns.  
 'Excel 2007 has 16384 columns.  
 'When you run one of the examples it will first delete the summary worksheet  
 'named RDBMergeSheet if it exists and then adds a new one to the workbook.  
 'This ensures that the data is always up to date after you run the code.  
 '*****READ THE TIPS on the website****  
 Sub AppendDataAfterLastColumn()  
 Dim sh As Worksheet  
 Dim DestSh As Worksheet  
 Dim Last As Long  
 Dim CopyRng As Range  
 With Application  
 .ScreenUpdating = False  
 .EnableEvents = False  
 End With  
 'Delete the sheet "RDBMergeSheet" if it exist  
 Application.DisplayAlerts = False  
 On Error Resume Next  
 ActiveWorkbook.Worksheets("RDBMergeSheet").Delete  
 On Error GoTo 0  
 Application.DisplayAlerts = True  
 'Add a worksheet with the name "RDBMergeSheet"  
 Set DestSh = ActiveWorkbook.Worksheets.Add  
 DestSh.Name = "RDBMergeSheet"  
 'loop through all worksheets and copy the data to the DestSh  
 For Each sh In ActiveWorkbook.Worksheets  
 'Loop through all worksheets except the RDBMerge worksheet and the  
 'Information worksheet, you can ad more sheets to the array if you want.  
 If IsError(Application.Match(sh.Name, _  
 Array(DestSh.Name, "Information"), 0)) Then  
 'Find the last Column with data on the DestSh  
 Last = LastCol(DestSh)  
 'Fill in the column(s) that you want to copy  
 Set CopyRng = sh.Range("A:A")  
 'Test if there enough rows in the DestSh to copy all the data  
 If Last + CopyRng.Columns.Count > DestSh.Columns.Count Then  
 MsgBox "There are not enough columns in the Destsh"  
 GoTo ExitTheSub  
 End If  
 'This example copies values/formats and Column width  
 CopyRng.Copy  
 With DestSh.Cells(1, Last + 1)  
 .PasteSpecial 8 ' Column width  
 .PasteSpecial xlPasteValues  
 .PasteSpecial xlPasteFormats  
 Application.CutCopyMode = False  
 End With  
 End If  
 Next  
 ExitTheSub:  
 Application.GoTo DestSh.Cells(1)  
 With Application  
 .ScreenUpdating = True  
 .EnableEvents = True  
 End With  
 End Sub  

Popular posts from this blog

Resolved : Power BI Report connection error during execution

Getting Below Power BI Report connection error during execution . Error: Something went wrong Unable to connect to the data source undefined. Please try again later or contact support. If you contact support, please provide these details. Underlying error code: -2147467259 Table: Business Sector. Underlying error message: AnalysisServices: A connection cannot be made. Ensure that the server is running. DM_ErrorDetailNameCode_UnderlyingHResult: -2147467259 Microsoft.Data.Mashup.ValueError.DataSourceKind: AnalysisServices Microsoft.Data.Mashup.ValueError.DataSourcePath: 10.10.10.60;T_CustomerMaster_ST Microsoft.Data.Mashup.ValueError.Reason: DataSource.Error Cluster URI: WABI-WEST-EUROPE-redirect.analysis.windows.net Activity ID: c72c4f12-8c27-475f-b576-a539dd81826a Request ID: dfb54166-c78f-4b40-779f-e8922a6687ad Time: 2019-09-26 10:03:29Z Solution: We found report connection not able to connect to SQL Analysis service so tried below option. Re

Song- Khamoshiyan Piano keyboard Chord,Notation and songs Lyrics

All songs notation and chords at one place

Song : O Saathi Re Film : Mukhathar Ka Sikkandhar Uses : C D D# E G A Note : The numbers at the end of the lines indicate line numbers. Pallavi: O saathi re, tere binaa bhi kya jina, tere binaa bhi kya jina A- C D D#....,D D C DD E...C..CA-...,D D C DD E...CC.......1 Play line 1 again phulon men khaliyon men sapnom ki galiyon men GGG...GAGE.. GGG G A G E.................................................2 tere bina kuchh kahin naa E A G E D C D D#.......................................................................3 tere binaa bhi kya jina, tere binaa bhi kya jina D D C DD E....C..CA-..., D D C DDE....CC.............................4 Charanam: har dhadkan men, pyaas hai teri, sanson men teri khushboo hai CCC C D C A-, CCC C D C A-, DDD DED CD EE.. CCCC......................5 is dharthi se, us ambar tak, meri nazar men tu hi tu hai CCC C D C A-, CCC C D C A-, DDD DED CD EE.. CCCC......................6 pyaar yeh tute naa GGG... GAG D#......E.........................