save(append) to an excel file

[Mark Elkins]

The following code will copy(append) a range to a .csv file. I am looking for
a way to save(append) to an excel file, rather than .csv?

Sub Append2CSV()
Dim tmpCSV As String 'string to hold the CSV info
Dim f As Integer
Dim CSVFile As String, varData As Variant
Dim myRng As String
Dim myRng2 As String
Dim myRng3 As String

myRng = Application.InputBox("Enter a number")

'Const CSVFile As String = "Z:\FILES\ACCOUNTING\PAYROLL\DAILY PROGRESS
REPORTS (DPRs)\WE 5-9-10\WE 5-9-10.csv" 'replace with your filename

f = FreeFile
myRng2 = "A2:N"
myRng3 = myRng2 & myRng

varData = InputBox("Enter Date")
If Not IsDate(varData) Then MsgBox "Invalid Date": Exit Sub

CSVFile = "Z:\FILES\ACCOUNTING\PAYROLL\DAILY PROGRESS REPORTS " & _
"(DPRs)\WE " & Format(CDate(varData), "m-d-yy") & "\WE " & _
Format(CDate(varData), "m-d-yy") & ".csv"

MsgBox CSVFile

Open CSVFile For Append As #f
tmpCSV = Range2CSV(Range(myRng3))
Print #f, tmpCSV
Close #f
End Sub

Function Range2CSV(list) As String
Dim tmp As String
Dim cr As Long
Dim r As Range

If TypeName(list) = "Range" Then
cr = 1

For Each r In list.Cells
If r.Row = cr Then
If tmp = vbNullString Then
tmp = r.Value
Else
tmp = tmp & "," & r.Value
End If
Else
cr = cr + 1
If tmp = vbNullString Then
tmp = r.Value
Else
tmp = tmp & Chr(10) & r.Value
End If
End If
Next
End If

Range2CSV = tmp
End Function

Thank you,

Mark

 

[Jacob Skaria]

Hi Mark

Try the below....

Sub Append2XLS()
Dim XLSFile As String, varData As Variant
Dim rngTemp As Range, myRng As String

myRng = Application.InputBox("Enter a number")
Set rngTemp = Range("A2:N" & myRng)

varData = InputBox("Enter Date")
If Not IsDate(varData) Then MsgBox "Invalid Date": Exit Sub

XLSFile = "Z:\FILES\ACCOUNTING\PAYROLL\DAILY PROGRESS REPORTS " & _
"(DPRs)\WE " & Format(CDate(varData), "m-d-yy") & "\WE " & _
Format(CDate(varData), "m-d-yy") & ".xls"

MsgBox XLSFile

Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wb = Workbooks.Open(XLSFile)
lngLastRow = wb.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
rngTemp.Copy wb.Sheets("Sheet1").Range("A" & lngLastRow + 1)
wb.Close True
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

 

[Mark Elkins]

Thank you Jacob!

I manually insert a unique header in the first row (from the workbook(s) I
append from) each time I create a new workbook to append. Do have a
suggestion on how I could insert this header if it doesn’t exist, but do
nothing if does exist? Also, is there a way to create the folder\excel file
if it doesn’t exist?

Thank you again for your generous help.

-Mark