Getting the name of the worksheet into A1 cell of each workbook, at the time of merging all the excels into one.

Shubhajit

New Member
Joined
Jul 20, 2015
Messages
2
Hi All,

I want to display the worksheet name of every worksheet from each workbook in A cell at the time of merging all the workbook into one. please help as i am unable to do so.

To display the worksheet name, i am using below mentioned macro:-

Sub SheetNames()
Columns(1).Insert
For i = 1 To Sheets.Count
Cells(i, 1) = Sheets(i).Name
Next i
End Sub

but also here i want to add the sheet name in all the worksheets in workbook.


For merging data, i am using below mentioned macro:-

Public Sub ConsolidateSheets()
Dim Wb1 As Workbook
Dim Wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim rngArea As Range
Dim lrowSpace As Long
Dim lSht As Long
Dim lngCalc As Long
Dim lngRow As Long
Dim lngCol As Long
Dim X()
Dim bProcessFolder As Boolean
Dim bNewSheet As Boolean

Dim StrPrefix
Dim strFileName As String
Dim strFolderName As String

'variant declaration needed for the Shell object to use a default directory
Dim strDefaultFolder As Variant


bProcessFolder = (MsgBox("Process a single folder (Yes)," & vbNewLine & "or single file (No)", vbYesNo, "Application Scope: Folder or single File") = vbYes)
bNewSheet = (MsgBox("Extract all data to a single sheet (Yes)," & vbNewLine & "or a target file sheet for each source sheet (No)", vbYesNo, "Output Format: Single sheet or sheet by sheet collection") = vbYes)
If Not bProcessFolder Then
If Not bNewSheet Then
MsgBox "There isn't much point creating a exact replica of your source file :)"
Exit Sub
End If
End If

'set default directory here if needed
strDefaultFolder = "E:\Excel_files"

'If the user is collating all the sheets to a single target sheet then the row spacing
'to distinguish between different sheets can be set here
lrowSpace = 1

If bProcessFolder Then
strFolderName = BrowseForFolder(strDefaultFolder)
'Look for xls, xlsx, xlsm files
strFileName = Dir(strFolderName & "\*.xls*")
Else
strFileName = Application _
.GetOpenFilename("Select file to process (*.xls*), *.xls*")
End If

Set Wb1 = Workbooks.Add(1)
Set ws1 = Wb1.Sheets(1)
If Not bNewSheet Then ws1.Range("A1:B1") = Array("workbook name", "worksheet count")

'Turn off screenupdating, events, alerts and set calculation to manual
With Application
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
End With

'set path outside the loop
StrPrefix = strFolderName & IIf(bProcessFolder, "\", vbNullString)

Do While Len(strFileName) > 0
'Provide progress status to user
Application.StatusBar = Left("Processing " & strFolderName & "\" & strFileName, 255)
'Open each workbook in the folder of interest
Set Wb2 = Workbooks.Open(StrPrefix & strFileName)
If Not bNewSheet Then
'add summary details to first sheet
ws1.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = Wb2.Name
ws1.Cells(Rows.Count, "A").End(xlUp).Offset(0, 1) = Wb2.Sheets.Count
End If
For Each ws2 In Wb2.Sheets
If bNewSheet Then
'All data to a single sheet
'Skip importing target sheet data if the source sheet is blank
Set rng2 = ws2.Cells.Find("*", ws2.[a1], xlValues, , xlByRows, xlPrevious)

If Not rng2 Is Nothing Then
Set rng1 = ws1.Cells.Find("*", ws1.[a1], xlValues, , xlByRows, xlPrevious)
'Find the first blank row on the target sheet
If Not rng1 Is Nothing Then
Set rng3 = ws2.Range(ws2.UsedRange.Cells(1), ws2.Cells(rng2.Row, "A"))
'Ensure that the row area in the target sheet won't be exceeded
If rng3.Rows.Count + rng1.Row < Rows.Count Then
'Copy the data from the used range of each source sheet to the first blank row
'of the target sheet, using the starting column address from the source sheet being copied
ws2.UsedRange.Copy ws1.Cells(rng1.Row + 1 + lrowSpace, ws2.UsedRange.Cells(1).Column)
Else
MsgBox "Summary sheet size exceeded. Process stopped on " & vbNewLine & _
"sheet: " & ws2.Name & vbNewLine & "of" & vbNewLine & "workbook: " & Wb2.Name
Wb2.Close False
Exit Do
End If
'colour the first of any spacer rows
If lrowSpace <> 0 Then ws1.Rows(rng1.Row + 1).Interior.Color = vbGreen
Else
'target sheet is empty so copy to first row
ws2.UsedRange.Copy ws1.Cells(1, ws2.UsedRange.Cells(1).Column)
End If
End If
Else
'new target sheet for each source sheet
ws2.Copy after:=Wb1.Sheets(Wb1.Sheets.Count)
'Remove any links in our target sheet
With Wb1.Sheets(Wb1.Sheets.Count).Cells
.Copy
.PasteSpecial xlPasteValues
End With
On Error Resume Next
Wb1.Sheets(Wb1.Sheets.Count).Name = ws2.Name
'sheet name already exists in target workbook
If Err.Number <> 0 Then
'Add a number to the sheet name till a unique name is derived
Do
lSht = lSht + 1
Set ws3 = Wb1.Sheets(ws2.Name & " " & lSht)
Loop While Not ws3 Is Nothing
lSht = 0
End If
On Error GoTo 0
End If
Next ws2
'Close the opened workbook
Wb2.Close False
'Check whether to force a DO loop exit if processing a single file
If bProcessFolder = False Then Exit Do
strFileName = Dir
Loop

'Remove any links if the user has used a target sheet
If bNewSheet Then
With ws1.UsedRange
.Copy
.Cells(1).PasteSpecial xlPasteValues
.Cells(1).Activate
End With
Else
'Format the summary sheet if the user has created separate target sheets
ws1.Activate
ws1.Range("A1:B1").Font.Bold = True
ws1.Columns.AutoFit
End If

With Application
.CutCopyMode = False
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
.Calculation = lngCalc
.StatusBar = vbNullString
End With
End Sub


Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'From Ken Puls as used in his vbaexpress.com article
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=284

Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0

'Destroy the Shell Application
Set ShellApp = Nothing

'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select

Exit Function

Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function
 

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.

Watch MrExcel Video

Forum statistics

Threads
1,133,244
Messages
5,657,583
Members
418,401
Latest member
B_A_M155

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top