CSV code works on some, but not all machines

[Ken Warthen]

I have an Excel 2003 worksheet with VBA code that creates a CSV file from
data on a worksheet. The file creation works fine on my machine as well as
several others, but there are at least two machines tested where the code
creates the CSV file, but when you open it there is no data in the worksheet.
Any idea what might be causing this? My code follows. - Ken

Public Sub sExportToCSV()
Dim ThisBook As Workbook
Dim thisSheet As Worksheet
Dim thisSelection As Range
Dim newBook As Workbook
Dim NewSheet As Worksheet
Dim Cell As Range
Dim strCSVFileName As String
Dim strPath As String

Set ThisBook = Selection.Parent.Parent
Set thisSheet = ThisBook.ActiveSheet
Set thisSelection = Range("CSVExportRange")

strPath = ActiveWorkbook.Path & "\"
strCSVFileName = Format(Date, "mmddyyyy") & ".csv"

'check for existing csv file
If Len(Dir(strPath & strCSVFileName)) > 0 Then
'file exists. append data
If fFileOpen(strPath & strCSVFileName) = True Then
'file is open
thisSelection.Copy
Application.DisplayAlerts = False
Workbooks(strCSVFileName).Activate
With Workbooks(strCSVFileName)
With Workbooks(strCSVFileName).ActiveSheet
.Range("A1").Select
Selection.End(xlDown).Select
'move down one cell
ActiveCell.Offset(1, 0).Select
ActiveCell.PasteSpecial
Paste:=xlPasteFormulasAndNumberFormats
End With
.Save
End With
Else
'file is not open
thisSelection.Copy
Application.DisplayAlerts = False
Set newBook = Workbooks.Open(strPath & strCSVFileName)
With newBook
Set NewSheet = newBook.ActiveSheet
With NewSheet
.Range("A1").Select
If Range("A1").Value = "" Then
ActiveCell.PasteSpecial
Paste:=xlPasteValuesAndNumberFormats
Else
Selection.End(xlDown).Select
'move down one cell
ActiveCell.Offset(1, 0).Select
ActiveCell.PasteSpecial
Paste:=xlPasteValuesAndNumberFormats
End If
End With
newBook.Save
newBook.Close
End With
Application.DisplayAlerts = True
ThisBook.Activate
End If
Else
'create new file
thisSelection.Copy
Set newBook = Workbooks.Add
Set NewSheet = newBook.ActiveSheet
ActiveCell.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.DisplayAlerts = False
newBook.SaveAs Filename:=strPath & strCSVFileName, FileFormat:=xlCSV
newBook.Close
Application.DisplayAlerts = True
ThisBook.Activate
End If



PROC_EXIT:
Exit Sub
End Sub

 

[ryguy7272]

Very bizarre. Do you down those two machines when you leave the office for
the day? Try a quick reboot and rerun. For something like this, it sounds
like RAM may bhe culprit. Well, just a guess.

HTH,
Ryan---

 

[Joel]

there were two serious problems with the code

1) I fmore than one workbook was opend this statement was a problem

''''''''''''''''''''''''''''''''''''''''''''''''
'Set thisSelection = Range("CSVExportRange")
Set thisSelection = thisSheet.Range("CSVExportRange")
''''''''''''''''''''''''''''''''''''''''''''''''

2) Activecell was indieterminate in the line below
''''''''''''''''''''''''''''''''''''''''''''''''
'ActiveCell.PasteSpecial Paste:=xlPasteValuesAndNumberFormats

NewSheet.range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
''''''''''''''''''''''''''''''''''''''''''''''''


3) I made other improvements. the two lines above should be fixed.
Public Sub sExportToCSV()
Dim ThisBook As Workbook
Dim thisSheet As Worksheet
Dim thisSelection As Range
Dim newBook As Workbook
Dim NewSheet As Worksheet
Dim Cell As Range
Dim strCSVFileName As String
Dim strPath As String

Set ThisBook = Selection.Parent.Parent
Set thisSheet = ThisBook.ActiveSheet
'''''''''''''''''''''''''''''''''''''''''''''''''
'Set thisSelection = Range("CSVExportRange")
Set thisSelection = thisSheet.Range("CSVExportRange")
''''''''''''''''''''''''''''''''''''''''''''''''

strPath = ActiveWorkbook.Path & "\"
strCSVFileName = Format(Date, "mmddyyyy") & ".csv"

'check for existing csv file
If Len(Dir(strPath & strCSVFileName)) > 0 Then
'file exists. append data
If fFileOpen(strPath & strCSVFileName) = True Then
'file is open
''''''''''''''''''''''''''''''''''''''''''''''''
'thisSelection.copy
''''''''''''''''''''''''''''''''''''''''''''''''
Application.DisplayAlerts = False
Workbooks(strCSVFileName).Activate
With Workbooks(strCSVFileName)
With Workbooks(strCSVFileName).ActiveSheet
''''''''''''''''''''''''''''''''''''''''''''''''
'.Range("A1").Select
'Selection.End(xlDown).Select
'move down one cell
'ActiveCell.Offset(1, 0).Select
'ActiveCell.PasteSpecial
'Paste:=xlPasteFormulasAndNumberFormats
set Lastcell = .Range("A1").End(xlDown)
'move down one cell
thisSelection.copy
LastCell.offset(1,0).PasteSpecial _
Paste:=xlPasteFormulasAndNumberFormats
''''''''''''''''''''''''''''''''''''''''''''''''
End With
.Save
End With
Else
'file is not open
''''''''''''''''''''''''''''''''''''''''''''''''
'thisSelection.Copy
''''''''''''''''''''''''''''''''''''''''''''''''
Application.DisplayAlerts = False
Set newBook = Workbooks.Open(strPath & strCSVFileName)
With newBook
Set NewSheet = newBook.ActiveSheet
With NewSheet
''''''''''''''''''''''''''''''''''''''''''''''''
'.Range("A1").Select
''''''''''''''''''''''''''''''''''''''''''''''''
If Range("A1").Value = "" Then
with .Range("A1")
thisSelection.Copy
.PasteSpecial _
Paste:=xlPasteValuesAndNumberFormats
Else
Set LastCell = .End(xlDown)
thisSelection.Copy
'move down one cell
LastCell.offset(1,0).PasteSpecial _
Paste:=xlPasteValuesAndNumberFormats
End If
End With
newBook.Save
newBook.Close
End With
Application.DisplayAlerts = True
ThisBook.Activate
End If
Else
'create new file
Set newBook = Workbooks.Add
Set NewSheet = newBook.ActiveSheet
thisSelection.Copy
''''''''''''''''''''''''''''''''''''''''''''''''
'ActiveCell.PasteSpecial Paste:=xlPasteValuesAndNumberFormats

NewSheet.range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
''''''''''''''''''''''''''''''''''''''''''''''''
Application.DisplayAlerts = False
newBook.SaveAs Filename:=strPath & strCSVFileName, FileFormat:=xlCSV
newBook.Close
Application.DisplayAlerts = True
ThisBook.Activate
End If



PROC_EXIT:
Exit Sub
End Sub

 

[Ken Warthen]

Joel,

Thanks for you suggestions. I'm not sure you understood what I was
attempting to do, but I used your sample to clean up my routine, and
hopefully provide greater clarity. The following code works on my computer,
but I won't get an opportunity to try it on the problem computers until
Monday.

Thanks again for taking the time to look at my code. My new code follows. -
Ken

Public Sub sExportToCSV()
Dim ThisBook As Workbook
Dim thisSheet As Worksheet
Dim thisSelection As Range
Dim newBook As Workbook
Dim NewSheet As Worksheet
Dim Cell As Range
Dim strCSVFileName As String
Dim strPath As String
Dim LastCell As Range

Set ThisBook = Selection.Parent.Parent
Set thisSheet = ThisBook.ActiveSheet
Set thisSelection = thisSheet.Range("CSVExportRange")

'copy the CSV data from worksheet
thisSelection.Copy

strPath = ActiveWorkbook.Path & "\"
strCSVFileName = Format(Date, "mmddyyyy") & ".csv"

Application.DisplayAlerts = False

'check for existing CSV file
If Len(Dir(strPath & strCSVFileName)) > 0 Then
'CSV file exists.

'check for open CSV file
If fFileOpen(strPath & strCSVFileName) = True Then
'CSV file is open. Append copied data
Workbooks(strCSVFileName).Activate
With Workbooks(strCSVFileName)
With Workbooks(strCSVFileName).ActiveSheet
Set LastCell = .Range("A1").End(xlDown)
LastCell.Offset(1, 0).PasteSpecial
Paste:=xlPasteValuesAndNumberFormats
End With
.Save
End With
Else
'CSV file is not open
Set newBook = Workbooks.Open(strPath & strCSVFileName)
With newBook
Set NewSheet = newBook.ActiveSheet
With NewSheet
Set LastCell = .Range("A1").End(xlDown)
If Range("A1").Value = "" Then
NewSheet.Range("A1").PasteSpecial
Paste:=xlPasteValuesAndNumberFormats
Else
LastCell.Offset(1, 0).PasteSpecial
Paste:=xlPasteValuesAndNumberFormats
End If
End With
newBook.Save
newBook.Close
End With
ThisBook.Activate
End If
Else
'CSV file does not exist. Create new CSV file
Set newBook = Workbooks.Add
Set NewSheet = newBook.ActiveSheet

NewSheet.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
newBook.SaveAs Filename:=strPath & strCSVFileName, FileFormat:=xlCSV
newBook.Close
ThisBook.Activate
End If

Application.DisplayAlerts = True


PROC_EXIT:
Exit Sub
End Sub