• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 301
  • Last Modified:

Excel Macro to open two excel files and merge them and send the merged one as an attachment

Dear Experts,

I would need your help in developing an excel macro.It would need to do the following:-

1)Open a text file at c:\myscripts\names.txt,where the file names of the two excel files to be opened will be stored with their locations.
2)Process those two files and merge them in one.
3)Delete two columns and format each column with a predefined width.
4)Send the file as an attachment in Outlook to the address contained in the text file stored in the directory (c:\myscripts\address)

Guys i need your special support to get me through this :)

Thanks
0
Talal216
Asked:
Talal216
  • 9
  • 8
1 Solution
 
bromy2004Commented:
What Columns did you want to delete?

If you can provide the 3 files, the Experts could supply a better macro than just guessing what you want.
0
 
Talal216Author Commented:
The following are the column names of the two excel sheets.The Colums that has to be Deleted are Entry#,Category.

Consultant      Date      Project      Client      Entry #      Project Description      Category            Task      Explanation      Hours      Rate      Total


The contents of the text file containing the names are as follows with a comma separationg the two

c:\Reports\TLDec2009FC.xls,
c:\Reports\TLDec2009LLP.xls


Thank you for your help :)
0
 
bromy2004Commented:
Try the Attached

Assumptions:
Headings are in Row 1
Data Starts in Row 2

Change the File Path to your Text File
Const TxtFilePath = "C:\testfile.txt"

about 3/4 of the way down there is an IF
Change the "Header2" and "Header4" to what you need
Making sure they are completely Lowercase

For i = ShtDest.UsedRange.Columns.Count To 1 Step -1
  If LCase(ShtDest.Cells(1, i).Value) = "header2" Or LCase(ShtDest.Cells(1, i).Value) = "header4" Then
  Columns(i).EntireColumn.Delete
  End If
Next i

Sub MergeFiles()
Const TxtFilePath = "C:\testfile.txt"
Const RowStart = 2
Const HeaderRow = 1

'Performance
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False

Dim FSO As Object, TxtFile As Object
Dim TxtString As String
Dim i As Integer
Dim NewWB As Workbook, OldWB As Workbook
Dim ShtDest As Worksheet
Dim CopyRng As Range, DestRng As Range
Dim CopyHeader As Boolean
Dim ArrTemp

''''''''''''''''
'Get File Names'
''''''''''''''''
Set FSO = CreateObject("Scripting.FileSystemObject")
Set TxtFile = FSO.OpenTextFile(TxtFilePath)
While TxtFile.AtEndOfStream = False
  TxtString = TxtString & TxtFile.ReadLine
Wend
ArrTemp = Split(TxtString, ",")
TxtFile.Close

CopyHeader = True
Set NewWB = Workbooks.Add
Set ShtDest = NewWB.Sheets(1)

'Merge Files
For i = LBound(ArrTemp) To UBound(ArrTemp)
  Set OldWB = Workbooks.Open(Filename:=ArrTemp(i), UpdateLinks:=False)
  If CopyHeader Then
    Set CopyRng = OldWB.Sheets(1).Range(Cells(HeaderRow, 1), Cells(HeaderRow, ActiveSheet.UsedRange.Columns.Count))
    Set DestRng = ShtDest.Range("A" & ShtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row)
    CopyRng.Copy DestRng
    i = i - 1
    CopyHeader = False
  Else
    Set CopyRng = OldWB.Sheets(1).Range(Cells(RowStart, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
    Set DestRng = ShtDest.Range("A" & ShtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
    CopyRng.Copy DestRng
  End If
  OldWB.Close
Next i

For i = ShtDest.UsedRange.Columns.Count To 1 Step -1
  If LCase(ShtDest.Cells(1, i).Value) = "header2" Or LCase(ShtDest.Cells(1, i).Value) = "header4" Then
  Columns(i).EntireColumn.Delete
  End If
Next i

Set NewWB = Nothing
Set OldWB = Nothing
Set TxtFile = Nothing
Set FSO = Nothing

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
End Sub

Open in new window

0
Free Tool: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
Talal216Author Commented:
Thank you very much for you help,bromy2004.

But i encounter an error 400 As soon as i run the script.
0
 
bromy2004Commented:
Could you please step through the Script and tell me what line it crashes on?

Also could you provide your modified version (With your path name ect.)

Cheers
0
 
Talal216Author Commented:
I have attached the files for your use.The script does not show any line numbers.i just hit Alt + F8 and in two seconds and error window pops up with error 400.
TLDec2009LLP.xls
TLDec2009FC.xls
Files.txt
Merge.xls
0
 
bromy2004Commented:
Try the Attached updated Code.

All options to change are now at the Top of the Declarations
Sub MergeFiles()
Const TxtFilePath = "Z:\Downloads - Chrome\Files.txt"
Const RowStart = 2
Const HeaderRow = 1
Const Delete1 = "entry#"
Const Delete2 = "category"
Const SheetName = "Time Listing"

'Performance
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False

Dim FSO As Object, TxtFile As Object
Dim TxtString As String
Dim i As Integer
Dim NewWB As Workbook, OldWB As Workbook
Dim ShtDest As Worksheet
Dim CopyRng As Range, DestRng As Range
Dim CopyHeader As Boolean
Dim ArrTemp

''''''''''''''''
'Get File Names'
''''''''''''''''
Set FSO = CreateObject("Scripting.FileSystemObject")
Set TxtFile = FSO.OpenTextFile(TxtFilePath)
While TxtFile.AtEndOfStream = False
  TxtString = TxtString & TxtFile.ReadLine
Wend
ArrTemp = Split(TxtString, ",")
TxtFile.Close

'Check Files exist
For i = LBound(ArrTemp) To UBound(ArrTemp)
  If Dir$(ArrTemp(i)) = "" Then
  MsgBox Prompt:="One of the Files doesn't exist" & vbNewLine & ArrTemp(i), Title:="Missing File"
  GoTo Finish
  Exit Sub
  End If
Next i

CopyHeader = True
Set NewWB = Workbooks.Add
Set ShtDest = NewWB.Sheets(1)

'Merge Files
For i = LBound(ArrTemp) To UBound(ArrTemp)
  Set OldWB = Workbooks.Open(Filename:=ArrTemp(i), UpdateLinks:=False)
  If CopyHeader Then
    Set CopyRng = OldWB.Sheets(SheetName).Range(Cells(HeaderRow, 1), Cells(HeaderRow, ActiveSheet.UsedRange.Columns.Count))
    Set DestRng = ShtDest.Range("A" & ShtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row)
    CopyRng.Copy DestRng
    i = i - 1
    CopyHeader = False
  Else
    Set CopyRng = OldWB.Sheets(SheetName).Range(Cells(RowStart, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
    Set DestRng = ShtDest.Range("A" & ShtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
    CopyRng.Copy DestRng
  End If
  OldWB.Close
Next i

For i = ShtDest.UsedRange.Columns.Count To 1 Step -1
  If LCase(ShtDest.Cells(1, i).Value) = Delete1 Or LCase(ShtDest.Cells(1, i).Value) = Delete2 Then
  Columns(i).EntireColumn.Delete
  End If
Next i

Finish:
Set NewWB = Nothing
Set OldWB = Nothing
Set TxtFile = Nothing
Set FSO = Nothing

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
End Sub

Open in new window

0
 
Talal216Author Commented:
Dear Bromy2004,

I tried this updated code but still i am facing the same problem.I have used them on the same files i have sent to you.
I have attached the errors i am receiving.

1) When i run Alt + F8

2) When i run it from the coding section itself.

Thanks bromy :)  for helping me.
RuntimeError400.JPG
RuntimeError.JPG
0
 
bromy2004Commented:
Could you please Step through the Code and advise what line the error appears?

Select any line in the Macro (While in VBA) and press F11 repeatedly until there the error appears.
0
 
Talal216Author Commented:
Line 52 the error appears.

0
 
bromy2004Commented:
What version of Excel do you have?
0
 
Talal216Author Commented:
VERSION 2007
0
 
bromy2004Commented:
I wrote the macro in 2007 and it worked fine.

are you using it with any other macros?
Could you provide your modified copy of the macro?
When you step through the macro, Did the new workbook/sheet get created?
0
 
bromy2004Commented:
also try and replace
Set ShtDest = NewWB.Sheets(1)
for
Set ShtDest = NewWB.Sheets.Add
0
 
Talal216Author Commented:
i will try that and let you know.
I have already uploaded the file which i have used its the same. I have not done any changes.
0
 
bromy2004Commented:
I've attached the Sheet I used.
Don't forget to change the Path in the Macro.
EE-Example-Copy-TXT-Files.xls
0
 
Talal216Author Commented:
Works Like a Charm
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Cloud Class® Course: Microsoft Exchange Server

The MCTS: Microsoft Exchange Server 2010 certification validates your skills in supporting the maintenance and administration of the Exchange servers in an enterprise environment. Learn everything you need to know with this course.

  • 9
  • 8
Tackle projects and never again get stuck behind a technical roadblock.
Join Now