I have a macro that I am running in Excel to separate 49 sheets into individual CSV files.
However, it is getting caught up on line 7
Application.ActiveWorkbook.SaveAs Filename: = xcsvFile, _
FileFormat: = xlCSV, CreateBackup: = False
Here's the surrounding code:
Sub ExportSheetsToCSV()
Dim xWs As Worksheet
For Each xWs In Application.ActiveWorkbook.Worksheets
xWs.Copy
Dim xcsvFile As String
xcsvFile = CurDir & "\" & xWs.Name & ".csv"
Application.ActiveWorkbook.SaveAs Filename: = xcsvFile, _
FileFormat: = xlCSV, CreateBackup: = False
Application.ActiveWorkbook.Saved = True
Application.ActiveWorkbook.Close
Next
End Sub
For each Sheet in workbook, transfer each sheet's name csv file.
Sub ExportSheetsToCSV()
Dim Ws As Worksheet
Dim xcsvFile As String
Dim rngDB As Range
For Each Ws In Worksheets
xcsvFile = CurDir & "\" & Ws.Name & ".csv"
With Ws
r = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
c = .Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Set rngDB = .Range("a1", .Cells(r, c))
End With
TransToCSV xcsvFile, rngDB
Next
MsgBox ("Files Saved Successfully")
End Sub
Sub TransToCSV(myfile As String, rng As Range)
Dim vDB, vR() As String, vTxt()
Dim i As Long, n As Long, j As Integer
Dim objStream
Dim strTxt As String
Set objStream = CreateObject("ADODB.Stream")
vDB = rng
For i = 1 To UBound(vDB, 1)
n = n + 1
ReDim vR(1 To UBound(vDB, 2))
For j = 1 To UBound(vDB, 2)
vR(j) = vDB(i, j)
Next j
ReDim Preserve vTxt(1 To n)
vTxt(n) = Join(vR, ",")
Next i
strTxt = Join(vTxt, vbCrLf)
With objStream
'.Charset = "utf-8"
.Open
.WriteText strTxt
.SaveToFile myfile, 2
.Close
End With
Set objStream = Nothing
End Sub
Consider this.
Sub test()
Dim ws As Worksheet
Dim GetSheetName As String
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Sheet1" Then ' Assuming there is one sheet that you DON'T want to save as a CSV
ws.Select
GetSheetName = ActiveSheet.Name
Set shtToExport = ActiveSheet ' Sheet to export as CSV
Set wbkExport = Application.Workbooks.Add
shtToExport.Copy Before:=wbkExport.Worksheets(wbkExport.Worksheets.Count)
Application.DisplayAlerts = False ' Possibly overwrite without asking
wbkExport.SaveAs Filename:="C:\your_path_here\Desktop\" & GetSheetName & ".csv", FileFormat:=xlCSV
Application.DisplayAlerts = True
wbkExport.Close SaveChanges:=False
End If
Next ws
End Sub
Related
I'm trying to write a code to open mentioned workbooks one by one and move & copy a particular worksheet into a new workbook
my code for the above mentioned task runs well till it opens the first file, then it gives me the following error
method or data member not found
Sub OpenFilesMoveCopyWorksheet()
Const PTH As String = "C:\Users\xxx\yyy\" 'use const for fixed values
Dim SFile As Workbook, SFname As Worksheet, SFname2 As Worksheet
Dim SFlname As String, I As Long, DFile As Workbook
Dim Acellrng As Range, ws As Worksheet, rngDest As Range, rngCopy As Range
Set SFile = ThisWorkbook
Set SFname = SFile.Worksheets("Sheet1")
Application.ScreenUpdating = False
For I = 1 To SFname.Cells(Rows.Count, "A").End(xlUp).Row
SFlname = SFname.Range("A" & I).Value
If Len(SFlname) > 0 Then
Set DFile = Workbooks.Open(PTH & SFlname)
If DFile.Worksheets.Name Like "*.cours" Then
DFile.Worksheet.copyafter: SFile.SFname
End If
DFile.Close savechanges:=False
End If
Next I
MsgBox "job done"
Application.ScreenUpdating = True
End Sub
Modified the code still getting "Run-time error'-2147221080 (800401a8)': Automation error"
Sub OpenFilesMoveCopyPaste()
Const PTH As String = "C:\xxx\yy\" 'use const for fixed values
Dim SFile As Workbook, SFname As Worksheet, SFname2 As Worksheet
Dim SFlname As String, I As Long, DFile As Workbook, I1 As Long, SFlname2 As String
Dim Acellrng As Range, ws As Worksheet, rngDest As Range, rngCopy As Range
Set SFile = ThisWorkbook
Set SFname = SFile.Worksheets("Sheet1")
Application.ScreenUpdating = False
For I = 1 To SFname.Cells(Rows.Count, "A").End(xlUp).Row
SFlname = SFname.Range("A" & I).Value
If Len(SFlname) > 0 Then
Set DFile = Workbooks.Open(PTH & SFlname)
For I1 = 1 To SFname.Cells(Rows.Count, "B").End(xlUp).Row
SFlname2 = SFname.Range("B" & I1).Value
If Len(SFlname2) > 0 Then
Set ws = DFile.Worksheets(SFlname2)
ws.copy Before:=SFile.Sheets("sheet1")
DFile.Close savechanges:=False
End If
Next I1
End If
Next I
MsgBox "job done"
Application.ScreenUpdating = True
End Sub
Final Version
Sub OpenFilesMoveCopyPasteSpecial()
Const PTH As String = "C:\XXX\YY\" 'use const for fixed values
Dim SFile As Workbook, SFname As Worksheet, SFname2 As Worksheet
Dim SFlname As String, I As Long, DFile As Workbook, I1 As Long, SFlname2 As String
Dim Acellrng As Range, ws As Worksheet, rngDest As Range, rngCopy As Range
Application.DisplayAlerts = False
Set SFile = ThisWorkbook
Set SFname = SFile.Worksheets("Sheet1")
Application.ScreenUpdating = False
For I = 1 To SFname.Cells(Rows.Count, "A").End(xlUp).Row
SFlname = SFname.Range("A" & I).Value
If Len(SFlname) > 0 Then
Set DFile = Workbooks.Open(PTH & SFlname)
Debug.Print DFile.Name
SFlname2 = SFname.Range("B" & I).Value
Set ws = DFile.Worksheets(SFlname2)
ws.copy After:=SFile.Sheets("sheet1")
Cells.Select
Range("AO1").Activate
Selection.copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
DFile.Close savechanges:=False
End If
Next I
MsgBox "job done"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Would like seek help on simplifying down some codes. it worked on some smaller set of data but unable to work on this larger set of around 750rows of data. The aim is to simplify down the data set by the criteria of Banker, and saved each filtered results based on Banker on a new tab, and then save as a separate workbook.
Sub seperate_by_banker()
Dim i, n As Integer
Dim banker As String
i = 2
n = Sheets("Banker").Range("A1").End(xlDown).Row
Do Until i = n
banker = Sheets("Banker").Range("A" & i)
Sheets("ASIA CHINA (PC)").Select
ActiveSheet.Range("$A$1:$Y$1000").AutoFilter Field:=7, Criteria1:= _
banker
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
ActiveSheet.Name = banker
i = i + 1
Loop
Call SplitWorkbook
End Sub
Sub SplitWorkbook()
'Updateby20200806
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim xNWb As Workbook
Dim FolderName As String
Application.ScreenUpdating = False
Set xWb = Application.ThisWorkbook
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = xWb.Path & "\" & xWb.Name & " " & DateString
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
Select Case xWb.FileFormat
Case 51:
FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If Application.ActiveWorkbook.HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56:
FileExtStr = ".xls": FileFormatNum = 56
Case Else:
FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
MkDir FolderName
For Each xWs In xWb.Worksheets
On Error GoTo NErro
If xWs.Visible = xlSheetVisible Then
xWs.Select
xWs.Copy
xFile = FolderName & "\" & xWs.Name & FileExtStr
Set xNWb = Application.Workbooks.Item(Application.Workbooks.Count)
xNWb.SaveAs xFile, FileFormat:=FileFormatNum
xNWb.Close False, xFile
End If
NErro:
xWb.Activate
Next
MsgBox "You can find the files in " & FolderName
Application.ScreenUpdating = True
End Sub
Please, try the next code. It uses array and copy the filtered range after transforming it in an array, so it should be very fast. No need of the second sub, no need of selections, which only consume Excel resources:
Sub seperate_by_banker()
Dim shB As Worksheet, shAC As Worksheet, wbNew As Workbook, lastR As Long, lastRAC As Long
Dim banker As String, rng As Range, rngF As Range, arrB, arr, i As Long, FolderName As String
Set shB = ThisWorkbook.Sheets("Banker")
lastR = shB.Range("A" & shB.rows.count).End(xlUp).row 'last row
arrB = shB.Range("A2:A" & lastR).Value2
Set shAC = ThisWorkbook.Sheets("ASIA CHINA (PC)")
lastRAC = shAC.Range("A" & shAC.rows.count).End(xlUp).row 'last row
FolderName = ThisWorkbook.path & "\" & ThisWorkbook.Name & " " & Format(Now, "yyyy-mm-dd hh-mm-ss")
If Dir(FolderName, vbDirectory) = "" Then MkDir FolderName 'create the folder if it does not exist
For i = 1 To UBound(arrB)
banker = arrB(i, 1)
shAC.AutoFilterMode = False 'eliminate the previous filter, if any
Set rng = shAC.Range("A1:Y" & lastRAC) 'set the range to be processed
rng.AutoFilter field:=6, Criteria1:=banker
Set rngF = rng.SpecialCells(xlCellTypeVisible) 'set a range to keep the filtered cells in the range
arr = arrayFromDiscRange(rngF, False) 'header inclusive
'create the necessary new workbook:
Set wbNew = Workbooks.Add
With wbNew.Sheets(1).Range("A1").Resize(UBound(arr), UBound(arr, 2))
.value = arr
.EntireColumn.AutoFit
End With
wbNew.saveas FolderName & "\" & banker & ".xlsx"
wbNew.Close False
Next i
End Sub
And the necessary function. It transforms the filtered (discontinuous) range in an array and paste it as fast as possible:
Private Function arrayFromDiscRange(rngF As Range, Optional NoHeader As Boolean = False) As Variant
Dim arr, i As Long, j As Long, k As Long, A As Range, R As Range, iRows As Long
'count range rows
For Each A In rngF.Areas
iRows = iRows + A.rows.count
Next A
'Redim the array to keep the range
ReDim arr(1 To iRows - IIf(NoHeader, 1, 0), 1 To rngF.Columns.count): k = 1
For Each A In rngF.Areas 'iterate between the range areas:
For Each R In A.rows 'iterate between the area rows:
If NoHeader And k = 1 Then GoTo Later 'skip the first row, if no header wanted
For j = 1 To R.Columns.count 'iterate between the area row columns:
arr(k, j) = R.cells(1, j).value 'place each row cells value in the array row
Next j
k = k + 1 'increment the array row to receive values
Later:
Next
Next A
arrayFromDiscRange = arr 'returning the created array
End Function
You could create the new workbooks directly from the filtered sheet.
Option Explicit
Sub separate_by_banker()
Dim wb As Workbook, wbNew As Workbook
Dim ws As Worksheet, wsData As Worksheet
Dim rng As Range, arBanker As Variant
Dim n As Long, iLastRow As Long
Dim foldername As String, sName As String
Set wb = ThisWorkbook
Set ws = wb.Sheets("Banker")
iLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
arBanker = ws.Range("A2:A" & iLastRow).Value2
Set wsData = wb.Sheets("ASIA CHINA (PC)")
iLastRow = wsData.Cells(Rows.Count, "A").End(xlUp).Row
Set rng = wsData.Range("A1:Y" & iLastRow)
' make folder for workbooks
foldername = wb.Path & "\" & wb.Name & " " & Format(Now, "yyyy-mm-dd hh-mm-ss")
MkDir foldername
Application.ScreenUpdating = False
For n = 1 To UBound(arBanker)
sName = arBanker(n, 1)
Set wbNew = Workbooks.Add(xlWBATWorksheet) ' 1 sheet
wbNew.Sheets(1).Name = sName
rng.AutoFilter Field:=7, Criteria1:=sName
rng.Copy
wbNew.Sheets(1).Paste
wbNew.Sheets(1).Columns("A:Y").AutoFit
wbNew.SaveAs foldername & "\" & sName & ".xlsx"
wbNew.Close False
Next
wsData.AutoFilterMode = False
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox n-1 & " files created in " & foldername, vbInformation
End Sub
I have the following VBA macro that I get from the web, a long time ago... and it´s working OK in Excel:
Sub ExportCSV()
Dim MyFileName As String
Dim CurrentWB As Workbook, TempWB As Workbook
Set CurrentWB = ActiveWorkbook
ActiveWorkbook.ActiveSheet.UsedRange.Copy
Set TempWB = Application.Workbooks.Add(1)
With TempWB.Sheets(1).Range("A1")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
MyFileName = CurrentWB.Path & "\FOLDER\" & Left(CurrentWB.Name, InStrRev(CurrentWB.Name, ".") - 1) & ".csv"
'Optionally, comment previous line and uncomment next one to save as the current sheet name
'MyFileName = CurrentWB.Path & "\" & CurrentWB.ActiveSheet.Name & ".csv"
Application.DisplayAlerts = False
TempWB.SaveAs Filename:=MyFileName, FileFormat:=xlCSVUTF8, CreateBackup:=False, Local:=False
TempWB.Close SaveChanges:=False
Application.DisplayAlerts = True
End Sub
I just need to edit/modify it to get only columns in the range "A:AV", to reduce the CSV file size... and simply, don´t know how to do it!
Can anyone help me?
Export Columns to CSV
Adjust the values in the constants section.
If your list separator is a semicolon, you may want to use Local:=True.
Option Explicit
Sub ExportColumnsToCSV()
Const sfRow As Long = 1
Const sColsList As String = "A:F,H:I,V,AM:AV"
Const dFirst As String = "A1"
Dim sCols() As String: sCols = Split(sColsList, ",")
Dim sws As Worksheet: Set sws = ActiveSheet
Dim swb As Workbook: Set swb = sws.Parent
Dim srrg As Range
Dim slCell As Range
Dim srCount As Long
With sws.Rows(sfRow)
Set slCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If slCell Is Nothing Then
MsgBox "No data in worksheet.", vbCritical, "Export to CSV"
Exit Sub
End If
srCount = slCell.Row - .Row + 1
Set srrg = .Resize(srCount)
End With
Dim srg As Range
Dim n As Long
For n = 0 To UBound(sCols)
If srg Is Nothing Then
Set srg = Intersect(srrg, sws.Columns(sCols(n)))
Else
Set srg = Union(srg, Intersect(srrg, sws.Columns(sCols(n))))
End If
Next n
Dim dwb As Workbook: Set dwb = Application.Workbooks.Add
srg.Copy
dwb.Worksheets(1).Range(dFirst).PasteSpecial xlPasteValues
Dim dFolderPath As String: dFolderPath = swb.Path & "\Folder\"
On Error Resume Next
MkDir dFolderPath
On Error GoTo 0
Dim dFilePath As String
dFilePath = dFolderPath _
& Left(swb.Name, InStrRev(swb.Name, ".") - 1) & ".csv"
' Optionally, out-comment previous line and uncomment next one
' to save with the current worksheet name.
'dFilePath = dFolderPath & sws.Name & ".csv"
Application.DisplayAlerts = False
dwb.SaveAs Filename:=dFilePath, FileFormat:=xlCSVUTF8, Local:=False
dwb.Close SaveChanges:=False
Application.DisplayAlerts = True
End Sub
Just for the sake of using arrays, next code will not use the clipboard. It is fast even for big ranges to be processed:
Sub ExportColumnsToCSV_Array()
Const sfRow As Long = 1
Const sColsList As String = "A:F,H:I,V,AM:AV"
Const dFirst As String = "A1"
Dim sCols() As String: sCols = Split(sColsList, ",")
Dim sws As Worksheet: Set sws = ActiveSheet
Dim swb As Workbook: Set swb = sws.Parent
Dim srrg As Range
Dim slCell As Range, arrCol, arr, lastRow As Long, lastCol As Long
If sws.UsedRange.cells.count <= 1 Then Exit Sub 'to avoid the next checking of lastRow and lastCol
With sws.rows(sfRow)
lastRow = .Resize(.Worksheet.rows.count - sfRow + 1) _
.Find("*", , xlFormulas, , xlByRows, xlPrevious).row 'last row of the range to be copied
End With
lastCol = ActiveSheet.Range("A1").SpecialCells(xlCellTypeLastCell).Column 'and its last column
arr = sws.Range("A1").Resize(lastRow, lastCol).value 'places the range to be copied in an array
'obtain array of necessary columns numbers:
arrCol = buildColAr(sColsList)
Debug.Print Join(arrCol, ","): 'just to see what array has been returned...
'Extract from the initial array only the necessary columns:
arr = Application.Index(arr, Application.Evaluate("row(1:" & lastRow & ")"), arrCol)
Dim dwb As Workbook: Set dwb = Application.Workbooks.Add
'drop the processed array result, at once:
dwb.Worksheets(1).Range(dFirst).Resize(UBound(arr), UBound(arr, 2)).value = arr
Dim dFolderPath As String: dFolderPath = swb.Path & "\Folder\"
If Dir(dFolderPath, vbDirectory) = "" Then MkDir dFolderPath
Dim dFilePath As String
dFilePath = dFolderPath & left(swb.Name, InStrRev(swb.Name, ".") - 1) & ".csv"
Application.DisplayAlerts = False
dwb.saveas FileName:=dFilePath, FileFormat:=xlCSVUTF8, Local:=False
dwb.Close SaveChanges:=False
Application.DisplayAlerts = True
End Sub
Private Function buildColAr(ByVal v As Variant) As Variant
Dim i&, temp, cols As Long, arrFilt, El, j As Long, k As Long
v = Split(v, ","): arrFilt = Filter(v, ":", True) 'in arrFilt will be kept the continuous ranges (like A:F)
For Each El In arrFilt
cols = cols + Range(El).Columns.count 'calculate the total number of columns to ReDim the array able to keep them
Next
ReDim temp(LBound(v) To UBound(v) - UBound(arrFilt) + cols - 1) 'Redim the necessary array to keep the columns number
For i = LBound(v) To UBound(v)
If InStr(v(i), ":") > 0 Then 'the case of adiacent columns ranges
For j = 1 To Range(v(i)).Columns.count
temp(k) = Range(v(i)).Columns(j).Column: k = k + 1
Next j
Else
temp(k) = cells(1, v(i)).Column: k = k + 1
End If
Next i
buildColAr = temp
End Function
The below code is take the Status of Col"E" If it is = Include then its corresponding sheets ranges will will be converted to PDF.
I have tried at my end but its not working receiving an error invalid procedure call or argument on the line
rng.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=saveLocation
Your help will be appreciated to fix the problem.
Sub SelectSheets_Ranges()
Dim sh As Worksheet, lastR As Long, rng As Range, arr, arrSplit, i As Long, k As Long
Set sh = ActiveSheet
lastR = sh.Range("C" & sh.Rows.Count).End(xlUp).Row
ReDim arr(lastR - 1)
For i = 6 To lastR
If sh.Range("E" & i).Value = "Include" Then
arr(k) = sh.Range("C" & i).Value & "|" & sh.Range("D" & i).Value: k = k + 1
End If
Next i
ReDim Preserve arr(k - 1)
For i = 0 To UBound(arr)
arrSplit = Split(arr(i), "|")
Set rng = Worksheets(arrSplit(0)).Range(arrSplit(1))
'Create and assign variables
Dim saveLocation As String
saveLocation = "C:\Users\marks\OneDrive\Documents\myPDFFile.pdf"
'Save a range as PDF
rng.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=saveLocation
Next
End Sub
Please, try the next code. It saves in ThisWorkbook path, naming the pdf file as "myPDFFile_sheetName.pdf". Each created file will be open in the default pdf application. If it works OK, you can appropriately change the last parameter:
Sub SelectSheets_Ranges_ExpPdf()
Dim sh As Worksheet, lastR As Long, rng As Range, arr, arrSplit, i As Long, k As Long
Set sh = ActiveSheet
lastR = sh.Range("C" & sh.Rows.Count).End(xlUp).Row
ReDim arr(lastR - 1)
For i = 6 To lastR
If sh.Range("E" & i).Value = "Include" Then
arr(k) = sh.Range("C" & i).Value & "|" & sh.Range("D" & i).Value: k = k + 1
End If
Next i
If k > 0 Then
ReDim Preserve arr(k - 1)
Else
MsgBox "No appropriate range (containing ""Include"") could be found...:exit sub"
End If
Dim boolHide As Boolean, boolProt As Boolean
ActiveWorkbook.Unprotect "4321" 'in order to unprotect he workbook structure
For i = 0 To UBound(arr)
boolHide = False: boolProt = False
arrSplit = Split(arr(i), "|")
Set rng = Worksheets(arrSplit(0)).Range(arrSplit(1))
If ActiveWorkbook.Sheets(arrSplit(0)).ProtectContents Then _
ActiveWorkbook.Sheets(arrSplit(0)).Unprotect "4321": boolProt = True
Debug.Print arrSplit(0)
If ActiveWorkbook.Sheets(arrSplit(0)).Visible <> xlSheetVisible Then _
ActiveWorkbook.Sheets(arrSplit(0)).Visible = xlSheetVisible: boolHide = True
'Create and assign variables
Dim saveLocation As String
saveLocation = ThisWorkbook.Path & "\myPDFFile_" & arrSplit(0) & ".pdf"
'Save a range as PDF
rng.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
saveLocation, Quality:=xlQualityStandard, IgnorePrintAreas:=False, OpenAfterPublish:=True
If boolHide Then ActiveWorkbook.Sheets(arrSplit(0)).Visible = xlSheetHidden
If boolProt Then ActiveWorkbook.Sheets(arrSplit(0)).Protect "4321"
Next
ActiveWorkbook.Protect "4321"
End Sub
Try this:
Sub SelectSheets_Ranges()
Dim sh As Worksheet, i As Long
Dim saveLocation As String, FirstSheet As Boolean
saveLocation = "C:\Users\marks\OneDrive\Documents\myPDFFile.pdf"
Set sh = ActiveSheet
FirstSheet = True
For i = 6 To sh.Range("C" & sh.Rows.Count).End(xlUp).Row
If sh.Cells(i, "E") = "Include" Then
'FirstSheet determines whether the sheet is added to currently-selected
' sheets or not (if not then it replaces them)
ThisWorkbook.Sheets(sh.Cells(i, "C").Value).Select FirstSheet
FirstSheet = False
End If
Next i
If Not FirstSheet Then
'at least one sheet was included
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=saveLocation
End If
End Sub
I assume you want all the ranges from the different sheets in one pdf.
Option Explicit
Sub SelectSheets_Ranges()
Const FOLDER = "C:\Users\marks\OneDrive\Documents\"
Const FILENAME = "myPDFFile.pdf"
Dim wb As Workbook, wbPDF As Workbook
Dim sh As Worksheet, wsPDF As Worksheet
Dim lastR As Long, rng As Range, r As Long, n As Integer, m As Integer
Set sh = ActiveSheet
Set wb = ActiveWorkbook
lastR = sh.Range("C" & sh.Rows.Count).End(xlUp).Row
' create temp workbook to hold ranges
Set wbPDF = Workbooks.Add
m = wbPDF.Sheets.Count
n = m
With sh
For r = 6 To lastR
If .Cells(r, "E").Value = "Include" Then
Set rng = wb.Sheets(.Cells(r, "C").Value).Range(.Cells(r, "D").Value)
Set wsPDF = wbPDF.Sheets.Add(After:=wbPDF.Sheets(n))
rng.Copy wsPDF.Range("A1")
n = n + 1
End If
Next
End With
' delete initial sheets
Application.DisplayAlerts = False
For n = m To 1 Step -1
wbPDF.Sheets(n).Delete
Next
Application.DisplayAlerts = True
'end
wbPDF.ExportAsFixedFormat Type:=xlTypePDF, FILENAME:=FOLDER & FILENAME
'wbPDF.SaveAs FOLDER & "debug.xlsx"
wbPDF.Close False
MsgBox "PDF created " & FOLDER & FILENAME, vbInformation
End Sub
I first create files in Excel. This macro saves all sheets into separate tab delimited text files.
How can I save with a tilde "~" instead of a tab?
Sub newworkbooks()
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
MyFilePath$ = ActiveWorkbook.Path & "\" & _
Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
' End With
On Error Resume Next '<< a folder exists
MkDir MyFilePath '<< create a folder
For N = 1 To Sheets.Count
Sheets(N).Activate
SheetName = ActiveSheet.Name
Cells.Copy
Workbooks.Add (xlWBATWorksheet)
With ActiveWorkbook
With .ActiveSheet
.Paste
.Name = SheetName
[A1].Select
End With
'save book in this folder
.saveas Filename:=MyFilePath _
& "\PO" & SheetName & ".txt", FileFormat:=xlTextWindows
.Close SaveChanges:=True
End With
.CutCopyMode = False
Next
End With
Sheet1.Activate
End Sub
Instead of looking like the following
this is a test
it should look like this
this~is~a~test
Here's one approach, which would be easy to modify to suit - this gives you control over the character set and the delimiter:
https://excel.solutions/2014/04/using-vba-write-excel-data-to-text-file/
Sub WriteTextFile()
Dim rng As Range, lRow As Long
Dim stOutput As String, stNextLine As String, stSeparator As String
Dim stFilename As String, stEncoding As String
Dim fso As Object
'-------------------------------------------------------------------------------------
'CHANGE THESE PARAMETERS TO SUIT
Set rng = ActiveSheet.UsedRange 'this is the range which will be written to text file
stFilename = "C:\Temp\TextOutput.txt" 'this is the text file path / name
stSeparator = vbTab 'e.g. for comma seperated value, change this to ","
stEncoding = "UTF-8" 'e.g. "UTF-8", "ASCII"
'-------------------------------------------------------------------------------------
For lRow = 1 To rng.Rows.Count
If rng.Columns.Count = 1 Then
stNextLine = rng.Rows(lRow).Value
Else
stNextLine = Join$(Application.Transpose(Application.Transpose(rng.Rows(lRow).Value)), stSeparator)
End If
If stOutput = "" Then
stOutput = stNextLine
Else
stOutput = stOutput & vbCrLf & stNextLine
End If
Next lRow
Set fso = CreateObject("ADODB.Stream")
With fso
.Type = 2
.Charset = stEncoding
.Open
.WriteText stOutput
.SaveToFile stFilename, 2
End With
Set fso = Nothing
End Sub
I'm sure you could adapt that to loop through your worksheets, and output the UsedRange of each.
EDIT:
Here's how to adapt it to use tilde as separator, and loop through each worksheet;
Sub OutputAllSheetsTildeSeparated()
Dim rng As Range, lRow As Long
Dim stOutput As String, stNextLine As String, stSeparator As String
Dim stFilepath As String, stFilename As String, stEncoding As String
Dim ws As Worksheet
Dim fso As Object
stFilepath = ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
stSeparator = "~"
stEncoding = "UTF-8"
If Dir(stFilepath, vbDirectory) = vbNullString Then MkDir stFilepath
For Each ws In ThisWorkbook.Worksheets
Set rng = ws.UsedRange
stFilename = stFilepath & "\PO" & ws.Name & ".txt"
For lRow = 1 To rng.Rows.Count
If rng.Columns.Count = 1 Then
stNextLine = rng.Rows(lRow).Value
Else
stNextLine = Join$(Application.Transpose(Application.Transpose(rng.Rows(lRow).Value)), stSeparator)
End If
If stOutput = "" Then
stOutput = stNextLine
Else
stOutput = stOutput & vbCrLf & stNextLine
End If
Next lRow
Set fso = CreateObject("ADODB.Stream")
With fso
.Type = 2
.Charset = stEncoding
.Open
.WriteText stOutput
.SaveToFile stFilename, 2
End With
Set fso = Nothing
Next ws
End Sub