write to CSV

[cyew]

Hi

I am new to VBA.

I have data on a number of sheets and I would like to write VBA codes
to loop through each sheet and write out the data in one CSV file.

eg

Sheet1
1 one
2 two
3 three

Sheet2
4 four
5 five
6 sixe


I would like my output CSV file to be:
1,one
2,two
3,three
4,four
5,five
6,sive


Thanks
Chen

 

[RB Smissaert]

Something like this should work:

Sub test()

Dim LR As Long
Dim oSheet As Worksheet
Dim hFile As Long
Dim strFile As String
Dim bOpenFile As Boolean
Dim arr

strFile = "C:\test.csv"

bOpenFile = True

For Each oSheet In ActiveWorkbook.Sheets
With oSheet
LR = .Cells(65536, 1).End(xlUp).Row
If Not IsEmpty(Cells(LR, 1)) Then
arr = Range(Cells(1), Cells(LR, 2))
SaveArrayToTextAppend strFile, arr, hFile, bOpenFile, False
bOpenFile = False
End If
End With
Next oSheet

Close #hFile

End Sub

Sub SaveArrayToTextAppend(strFile As String, _
arr As Variant, _
hFile As Long, _
Optional bOpenFile As Boolean = True, _
Optional bCloseFile As Boolean = True, _
Optional ByVal LBRow As Long = -1, _
Optional ByVal UBRow As Long = -1, _
Optional ByVal LBCol As Long = -1, _
Optional ByVal UBCol As Long = -1)

Dim r As Long
Dim c As Long

If LBRow = -1 Then
LBRow = LBound(arr, 1)
End If

If UBRow = -1 Then
UBRow = UBound(arr, 1)
End If

If LBCol = -1 Then
LBCol = LBound(arr, 2)
End If

If UBCol = -1 Then
UBCol = UBound(arr, 2)
End If

If bOpenFile Then
hFile = FreeFile
Open strFile For Append As #hFile
End If

For r = LBRow To UBRow
For c = LBCol To UBCol
If c = UBCol Then
Write #hFile, arr(r, c)
Else
Write #hFile, arr(r, c);
End If
Next c
Next r

If bCloseFile Then
Close #hFile
End If

End Sub


RBS

 

[keiji kounoike]

One way, but not so fast.
If your workbook's name is Book1.xls, this macro would create a file
named Book1.csv in the same folder with Book1.xls

Sub Worbook2Csv()
Dim Csvname As String, Pdir As String
Dim TmpWB As Workbook, AcWB As Workbook
Dim Fname() As String
Dim SelSh As Sheets, Wsh As Worksheet
Dim filenum
Dim i As Long

Pdir = ActiveWorkbook.path
Csvname = ActiveWorkbook.Name
Csvname = Left(Csvname, InStr(Csvname, ".") - 1)
ChDir Pdir
Set AcWB = ActiveWorkbook
Set SelSh = AcWB.Worksheets

SelSh.Copy
Set TmpWB = ActiveWorkbook

Application.DisplayAlerts = False
Application.ScreenUpdating = False

ReDim Fname(TmpWB.Worksheets.Count - 1)

For Each Wsh In TmpWB.Worksheets
Wsh.Select
TmpWB.SaveAs Filename:=Csvname & "Tmp" & CStr(i), _
FileFormat:=xlCSV, CreateBackup:=False
Fname(i) = TmpWB.FullName
i = i + 1
Next
TmpWB.Close

Open Fname(0) For Append As #1
For i = 1 To UBound(Fname)
filenum = FreeFile
Open Fname(i) For Input As #filenum
Do While Not EOF(filenum)
Line Input #filenum, tmp
Print #1, tmp
Loop
Close #filenum
Kill Fname(i)
Next
Close #1

Name Fname(0) As Replace(Fname(0), "Tmp0", "")

Keiji

 

[cyew]

One way, but not so fast.
If your workbook's name is Book1.xls, this macro would create a file
named Book1.csv in the same folder with Book1.xls

Sub Worbook2Csv()
Dim Csvname As String, Pdir As String
Dim TmpWB As Workbook, AcWB As Workbook
Dim Fname() As String
Dim SelSh As Sheets, Wsh As Worksheet
Dim filenum
Dim i As Long

Pdir = ActiveWorkbook.path
Csvname = ActiveWorkbook.Name
Csvname = Left(Csvname, InStr(Csvname, ".") - 1)
ChDir Pdir
Set AcWB = ActiveWorkbook
Set SelSh = AcWB.Worksheets

SelSh.Copy
Set TmpWB = ActiveWorkbook

Application.DisplayAlerts = False
Application.ScreenUpdating = False

ReDim Fname(TmpWB.Worksheets.Count - 1)

For Each Wsh In TmpWB.Worksheets
     Wsh.Select
     TmpWB.SaveAs Filename:=Csvname & "Tmp" & CStr(i), _
         FileFormat:=xlCSV, CreateBackup:=False
     Fname(i) = TmpWB.FullName
     i = i + 1
Next
TmpWB.Close

Open Fname(0) For Append As #1
For i = 1 To UBound(Fname)
     filenum = FreeFile
     Open Fname(i) For Input As #filenum
     Do While Not EOF(filenum)
         Line Input #filenum, tmp
         Print #1, tmp
     Loop
     Close #filenum
     Kill Fname(i)
Next
Close #1

Name Fname(0) As Replace(Fname(0), "Tmp0", "")

Keiji

Thanks All for your help.

Chen