Merge Multiple Worksheet Using VBA

[punnipah]

Hi,All

I Would like to Merge Multiple Worksheet Using a VBA

This my Code :Opend All File.CSV (about 100 File)

Sub GetSheets()
path = "C:\Users\Myname\Desktop\Tele Outsource Macro\Input\"
fileName = Dir(path & "*.csv")
Do While fileName <> ""
Workbooks.Open fileName:=path & fileName, ReadOnly:=True
For Each sheet In ActiveWorkbook.Sheets
sheet.Copy After:=ThisWorkbook.Sheets(1)
Next sheet
Workbooks(fileName).Close
fileName = Dir()
Loop
End Sub

And Next Step I Would like to Merge Multiple Worksheet to one sheet
and (columns header select only one) Becase 100 File is the same data.


Thank you.

 

[ranman256]

paste the code into a module, then call it with the folder you want to merge.
or hardcode your starting folder
usage:
MergeAllFilesInDir "c:\temp\Test2"

Public Function MergeAllFilesInDir(ByVal pvDir)
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 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

 

[punnipah]

ct("Scripting

paste the code into a module, then call it with the folder you want to merge.
or hardcode your starting folder
usage:
MergeAllFilesInDir "c:\temp\Test2"

Public Function MergeAllFilesInDir(ByVal pvDir)
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 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

Thank You Very much.

 

[punnipah]

ranman256​

I can't to Run please help Edit This Code

Thank you

======================================
Sub GetSheets()
path = "C:\Users\punnipah\Desktop\Tele Outsource Macro\Input\"
fileName = Dir(path & "*.csv")
Do While fileName <> ""
Workbooks.Open fileName:=path & fileName, ReadOnly:=True
For Each sheet In ActiveWorkbook.Sheets
sheet.Copy After:=ThisWorkbook.Sheets(1)
Next sheet
Workbooks(fileName).Close
fileName = Dir()
Loop


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