?
Solved

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

Posted on 2009-12-17
17
Medium Priority
?
297 Views
Last Modified: 2012-05-08
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
Comment
Question by:Talal216
  • 9
  • 8
17 Comments
 
LVL 10

Expert Comment

by:bromy2004
ID: 26077919
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
 

Author Comment

by:Talal216
ID: 26088831
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
 
LVL 10

Expert Comment

by:bromy2004
ID: 26093383
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
Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 

Author Comment

by:Talal216
ID: 26093943
Thank you very much for you help,bromy2004.

But i encounter an error 400 As soon as i run the script.
0
 
LVL 10

Expert Comment

by:bromy2004
ID: 26093951
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
 

Author Comment

by:Talal216
ID: 26094034
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
 
LVL 10

Expert Comment

by:bromy2004
ID: 26094137
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
 

Author Comment

by:Talal216
ID: 26094381
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
 
LVL 10

Expert Comment

by:bromy2004
ID: 26116573
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
 

Author Comment

by:Talal216
ID: 26125426
Line 52 the error appears.

0
 
LVL 10

Expert Comment

by:bromy2004
ID: 26168145
What version of Excel do you have?
0
 

Author Comment

by:Talal216
ID: 26170555
VERSION 2007
0
 
LVL 10

Expert Comment

by:bromy2004
ID: 26170899
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
 
LVL 10

Expert Comment

by:bromy2004
ID: 26170913
also try and replace
Set ShtDest = NewWB.Sheets(1)
for
Set ShtDest = NewWB.Sheets.Add
0
 

Author Comment

by:Talal216
ID: 26180649
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
 
LVL 10

Accepted Solution

by:
bromy2004 earned 2000 total points
ID: 26187147
I've attached the Sheet I used.
Don't forget to change the Path in the Macro.
EE-Example-Copy-TXT-Files.xls
0
 

Author Closing Comment

by:Talal216
ID: 31675394
Works Like a Charm
0

Featured Post

Concerto's Cloud Advisory Services

Want to avoid the missteps to gaining all the benefits of the cloud? Learn more about the different assessment options from our Cloud Advisory team.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

How to get Spreadsheet Compare 2016 working with the 64 bit version of Office 2016
This article describes a serious pitfall that can happen when deleting shapes using VBA.
The viewer will learn how to use a discrete random variable to simulate the return on an investment over a period of years, create a Monte Carlo simulation using the discrete random variable, and create a graph to represent the possible returns over…
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.

749 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question