Public Sub WriteCSV() Set wkb = ActiveSheet Dim fileName As String Dim MaxCols As Integer fileName = Application.GetSaveAsFilename("", "CSV File (*.csv), *.csv") If fileName = "False" Then End End If On Error GoTo eh Const adTypeText = 2 Const adSaveCreateOverWrite = 2 Dim BinaryStream Set BinaryStream = CreateObject("ADODB.Stream") BinaryStream.Charset = "UTF-8" BinaryStream.Type = adTypeText BinaryStream.Open For r = 1 To 10 s = "" c = 1 While Not IsEmpty(wkb.Cells(r, c).Value) s = s & wkb.Cells(r, c).Value & "," c = c + 1 Wend BinaryStream.WriteText s, 1 Next r BinaryStream.SaveToFile fileName, adSaveCreateOverWrite BinaryStream.Close MsgBox "CSV generated successfully" eh: End Sub
PS: You need to click the macro once on each Sheet page, pop up the window, select Save as name, click OK, save as UTF8 format CSV, and only export 10 lines each, stop when the content on the line is empty