Merge worksheets with same name.

P

punnipah

Board Regular
Joined
Nov 3, 2021
Messages
134
Office Version
  1. 2019
Platform
  1. Windows
Hi

I have multiple Excel with same worksheet names. i want a macros to merge the worksheets with same name- in to New Excel File.

Example
Worksheets A>>>Name>>>PNN12
Worksheets B>>>Name>>>PNN13
Worksheets C>>>Name>>>FNN12
Worksheets D>>>Name>>>FNN13

Output
1.New File Worksheets A & B merge 1 Sheet (Not included Header)
-Insert Columns : if Worksheets A >>PNN12 and if Worksheets B >>PNN13

2.New File Worksheets C & D merge 1 Sheet (Not included Header)
-Insert Columns : if Worksheets B >>FNN12 and if Worksheets D >>FNN13


Please help me with the VBA Scipt Code.

Thank You.
 

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.
Sort by date Sort by votes
paste the code into a module,
then submit the folder and the 'key name' of the files to merge to the function
usage:
MergeAllFilesInDir "c:\temp\Test2", "PNN"

Code: 
Public Function MergeAllFilesInDir(ByVal pvDir, ByVal pvFName)
Dim fso, oFolder, oFile, oRX
Dim sTxt As String, sFile As String, sLtr As String
Dim wbSrc As Workbook, wbTarg As Workbook
Dim iRows As Long, iCols As Long, i As Long
Dim vAddr
Set wbTarg = ActiveWorkbook
Set fso = CreateObject("Scripting.FileSystemObject")
Set oFolder = fso.GetFolder(pvDir)
Range("A1").Select
i = 1
For Each oFile In oFolder.Files
  If InStr(oFile.Name, ".xls") > 0 And InStr(oFile.Name, pvFName) > 0 Then
      Workbooks.Open oFile
      Set wbSrc = ActiveWorkbook
      iRows = ActiveSheet.UsedRange.Rows.Count
      iCols = ActiveSheet.UsedRange.Columns.Count
      vAddr = Cells(1, iCols).Address
      sLtr = getColLetter(vAddr)
     
      If i = 1 Then
         ActiveSheet.UsedRange.Select
      Else
        Range("A2:" & sLtr & iRows).Select
      End If
      Selection.Copy
     
      wbTarg.Activate
      Go2Bottom
      ActiveSheet.Paste
      Application.CutCopyMode = False
     
      'Debug.Print oFile.Name, iRows
      wbSrc.Close False
      i = i + 1
  End If
Next
Set oFile = Nothing
Set oFolder = Nothing
Set fso = Nothing
Set wbSrc = Nothing
Set wbTarg = Nothing
End Function

Private Function getColLetter(vAddr)
Dim i As Integer
    vAddr = Mid(vAddr, 2)
    i = InStr(vAddr, "$")
    getColLetter = Left(vAddr, i - 1)
End Function

Private Sub Go2Bottom()
Range("A1").Select
Select Case True
  Case ActiveCell.Offset(0, 0).Value = ""
    'do nothing
  Case ActiveCell.Offset(1, 0).Value = ""
    'move to row2
     ActiveCell.Offset(1, 0).Select
  Case Else  'move to bottom
     Selection.End(xlDown).Select
     ActiveCell.Offset(1, 0).Select
End Select
End Sub
paste the code into a module,
then submit the folder and the 'key name' of the files to merge
usage:
MergeAllFilesInDir "c:\temp\Test2", "PNN"

Code: 
Public Function MergeAllFilesInDir(ByVal pvDir, ByVal pvFName)
Dim fso, oFolder, oFile, oRX
Dim sTxt As String, sFile As String, sLtr As String
Dim wbSrc As Workbook, wbTarg As Workbook
Dim iRows As Long, iCols As Long, i As Long
Dim vAddr
Set wbTarg = ActiveWorkbook
Set fso = CreateObject("Scripting.FileSystemObject")
Set oFolder = fso.GetFolder(pvDir)
Range("A1").Select
i = 1
For Each oFile In oFolder.Files
  If InStr(oFile.Name, ".xls") > 0 And InStr(oFile.Name, pvFName) > 0 Then
      Workbooks.Open oFile
      Set wbSrc = ActiveWorkbook
      iRows = ActiveSheet.UsedRange.Rows.Count
      iCols = ActiveSheet.UsedRange.Columns.Count
      vAddr = Cells(1, iCols).Address
      sLtr = getColLetter(vAddr)
     
      If i = 1 Then
         ActiveSheet.UsedRange.Select
      Else
        Range("A2:" & sLtr & iRows).Select
      End If
      Selection.Copy
     
      wbTarg.Activate
      Go2Bottom
      ActiveSheet.Paste
      Application.CutCopyMode = False
     
      'Debug.Print oFile.Name, iRows
      wbSrc.Close False
      i = i + 1
  End If
Next
Set oFile = Nothing
Set oFolder = Nothing
Set fso = Nothing
Set wbSrc = Nothing
Set wbTarg = Nothing
End Function

Private Function getColLetter(vAddr)
Dim i As Integer
    vAddr = Mid(vAddr, 2)
    i = InStr(vAddr, "$")
    getColLetter = Left(vAddr, i - 1)
End Function

Private Sub Go2Bottom()
Range("A1").Select
Select Case True
  Case ActiveCell.Offset(0, 0).Value = ""
    'do nothing
  Case ActiveCell.Offset(1, 0).Value = ""
    'move to row2
     ActiveCell.Offset(1, 0).Select
  Case Else  'move to bottom
     Selection.End(xlDown).Select
     ActiveCell.Offset(1, 0).Select
End Select
End Sub
 
Upvote 0
Solution
ranman256 said:
paste the code into a module,
then submit the folder and the 'key name' of the files to merge to the function
usage:
MergeAllFilesInDir "c:\temp\Test2", "PNN"

Code: 
Public Function MergeAllFilesInDir(ByVal pvDir, ByVal pvFName)
Dim fso, oFolder, oFile, oRX
Dim sTxt As String, sFile As String, sLtr As String
Dim wbSrc As Workbook, wbTarg As Workbook
Dim iRows As Long, iCols As Long, i As Long
Dim vAddr
Set wbTarg = ActiveWorkbook
Set fso = CreateObject("Scripting.FileSystemObject")
Set oFolder = fso.GetFolder(pvDir)
Range("A1").Select
i = 1
For Each oFile In oFolder.Files
  If InStr(oFile.Name, ".xls") > 0 And InStr(oFile.Name, pvFName) > 0 Then
      Workbooks.Open oFile
      Set wbSrc = ActiveWorkbook
      iRows = ActiveSheet.UsedRange.Rows.Count
      iCols = ActiveSheet.UsedRange.Columns.Count
      vAddr = Cells(1, iCols).Address
      sLtr = getColLetter(vAddr)
    
      If i = 1 Then
         ActiveSheet.UsedRange.Select
      Else
        Range("A2:" & sLtr & iRows).Select
      End If
      Selection.Copy
    
      wbTarg.Activate
      Go2Bottom
      ActiveSheet.Paste
      Application.CutCopyMode = False
    
      'Debug.Print oFile.Name, iRows
      wbSrc.Close False
      i = i + 1
  End If
Next
Set oFile = Nothing
Set oFolder = Nothing
Set fso = Nothing
Set wbSrc = Nothing
Set wbTarg = Nothing
End Function

Private Function getColLetter(vAddr)
Dim i As Integer
    vAddr = Mid(vAddr, 2)
    i = InStr(vAddr, "$")
    getColLetter = Left(vAddr, i - 1)
End Function

Private Sub Go2Bottom()
Range("A1").Select
Select Case True
  Case ActiveCell.Offset(0, 0).Value = ""
    'do nothing
  Case ActiveCell.Offset(1, 0).Value = ""
    'move to row2
     ActiveCell.Offset(1, 0).Select
  Case Else  'move to bottom
     Selection.End(xlDown).Select
     ActiveCell.Offset(1, 0).Select
End Select
End Sub
paste the code into a module,
then submit the folder and the 'key name' of the files to merge
usage:
MergeAllFilesInDir "c:\temp\Test2", "PNN"

Code: 
Public Function MergeAllFilesInDir(ByVal pvDir, ByVal pvFName)
Dim fso, oFolder, oFile, oRX
Dim sTxt As String, sFile As String, sLtr As String
Dim wbSrc As Workbook, wbTarg As Workbook
Dim iRows As Long, iCols As Long, i As Long
Dim vAddr
Set wbTarg = ActiveWorkbook
Set fso = CreateObject("Scripting.FileSystemObject")
Set oFolder = fso.GetFolder(pvDir)
Range("A1").Select
i = 1
For Each oFile In oFolder.Files
  If InStr(oFile.Name, ".xls") > 0 And InStr(oFile.Name, pvFName) > 0 Then
      Workbooks.Open oFile
      Set wbSrc = ActiveWorkbook
      iRows = ActiveSheet.UsedRange.Rows.Count
      iCols = ActiveSheet.UsedRange.Columns.Count
      vAddr = Cells(1, iCols).Address
      sLtr = getColLetter(vAddr)
    
      If i = 1 Then
         ActiveSheet.UsedRange.Select
      Else
        Range("A2:" & sLtr & iRows).Select
      End If
      Selection.Copy
    
      wbTarg.Activate
      Go2Bottom
      ActiveSheet.Paste
      Application.CutCopyMode = False
    
      'Debug.Print oFile.Name, iRows
      wbSrc.Close False
      i = i + 1
  End If
Next
Set oFile = Nothing
Set oFolder = Nothing
Set fso = Nothing
Set wbSrc = Nothing
Set wbTarg = Nothing
End Function

Private Function getColLetter(vAddr)
Dim i As Integer
    vAddr = Mid(vAddr, 2)
    i = InStr(vAddr, "$")
    getColLetter = Left(vAddr, i - 1)
End Function

Private Sub Go2Bottom()
Range("A1").Select
Select Case True
  Case ActiveCell.Offset(0, 0).Value = ""
    'do nothing
  Case ActiveCell.Offset(1, 0).Value = ""
    'move to row2
     ActiveCell.Offset(1, 0).Select
  Case Else  'move to bottom
     Selection.End(xlDown).Select
     ActiveCell.Offset(1, 0).Select
End Select
End Sub
Click to expand...
Thank you very much.
 
Upvote 0
You must log in or register to reply here.

Similar threads

noisepoet
  • Solved
unprotect sheet via vba works first time, says incorrect password second time
Replies
3
Views
151
Fluff
Fluff
P
  • Question
VBA to copy multiple worksheets and either rename sheet with file name or add column with filename
Replies
5
Views
1K
I_know_nuffin
I
M
  • Question
Do I have to repeat the same procedure to match combobox with two sheets and different columns
Replies
0
Views
25
Maklil
M
J
  • Question
easy fix just need first sheet only in each file on this copy all first sheets into one workbook
Replies
2
Views
152
jordanburch
J
S
  • Question
Creating new sheets from template sheet plugging data into new sheets with particular criterias
Replies
1
Views
32
mumps
mumps

Forum statistics

Threads
1,215,054
Messages
6,122,893
Members
449,097
Latest member
dbomb1414

Share this page

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
Back
Top