Home |
Search |
Today's Posts |
#1
![]()
Posted to microsoft.public.excel.worksheet.functions
|
|||
|
|||
![]()
I am using the code below to convert (and save) a worksheet to a csv file.
For some reason, the code is not saving the entire contents of the worksheet. Can someone recommend a change to the code so that it will convert and save the entire contents of the selected worksheet ? Thank you in advance. Sheets(Array("1", "2")).Select Sheets("1").Activate ' save selected sheets as individual workbooks and convert to csv ' ChDir "J:\PROJECTS\close" Dim sh As Worksheet Dim Nwb As Workbook Application.ScreenUpdating = False For Each sh In ActiveWindow.SelectedSheets sh.Copy Set Nwb = ActiveWorkbook Nwb.SaveAs Filename:=sh.Name & "_" & Format(Now, "mm-dd-yy") Nwb.Close False Next 'Application.ScreenUpdating = True 'ActiveWorkbook.Close savechanges:=False 'convert selected sheets to csv Dim FName As Variant Dim N As Long Dim Awb As Workbook FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xls), *.xls", _ MultiSelect:=True) If IsArray(FName) Then Application.ScreenUpdating = False For N = LBound(FName) To UBound(FName) Set Awb = Workbooks.Open(FName(N)) ExportToTextFile Left(Awb.Name, Len(Awb.Name) - 4) & ".csv", ";", False Awb.Close savechanges:=False Next Application.ScreenUpdating = True End If Application.ScreenUpdating = True ActiveWorkbook.Close savechanges:=False End Sub Public Sub ExportToTextFile(FName As String, Sep As String, SelectionOnly As Boolean) Dim WholeLine As String Dim FNum As Integer Dim RowNdx As Long Dim ColNdx As Integer Dim StartRow As Long Dim EndRow As Long Dim StartCol As Integer Dim EndCol As Integer Dim CellValue As String Application.ScreenUpdating = False On Error GoTo EndMacro: FNum = FreeFile If SelectionOnly = True Then With Selection StartRow = .Cells(1).Row StartCol = .Cells(1).Column EndRow = .Cells(.Cells.Count).Row EndCol = .Cells(.Cells.Count).Column End With Else With ActiveSheet.UsedRange StartRow = .Cells(1).Row StartCol = .Cells(1).Column EndRow = .Cells(.Cells.Count).Row EndCol = .Cells(.Cells.Count).Column End With End If Open FName For Output Access Write As #FNum For RowNdx = StartRow To EndRow WholeLine = "" For ColNdx = StartCol To EndCol If Cells(RowNdx, ColNdx).Value = "" Then CellValue = Chr(34) & Chr(34) Else CellValue = Cells(RowNdx, ColNdx).Text End If WholeLine = WholeLine & CellValue & Sep Next ColNdx WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep)) Print #FNum, WholeLine Next RowNdx EndMacro: On Error GoTo 0 Application.ScreenUpdating = True Close #FNum End Sub |
Thread Tools | Search this Thread |
Display Modes | |
|
|
![]() |
||||
Thread | Forum | |||
Strange problem with Code | Excel Worksheet Functions | |||
Little problem with this code... | Excel Discussion (Misc queries) | |||
Can anyone figure this code problem please | Excel Discussion (Misc queries) | |||
Problem with criteria when using it from VBA Code | Excel Worksheet Functions | |||
Problem with Date format from VBA code | Excel Discussion (Misc queries) |