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
