I need to export multiple ranges from different worksheet in to a single text file I want the the cell ranges to append one after another. Currently I'm using this code which works perfectly for one range one worksheet what do I need to modify this to make it work with more ranges?
Example ranges I would like to add
Sheet1 A2:E50
Sheet2 A2:F60
Sheet4 A2:C45
Current code
Sub Export()
Dim r As Range, c As Range
Dim sTemp As String
Open Workbooks("Test.xlsm").Path & "\Test.SQL" For Output As #1
For Each r In Worksheets("SQL1").Range("A1:D50").Rows
sTemp = ""
For Each c In r.Cells
sTemp = sTemp & c.Text & Chr(9)
Next c
'Get rid of trailing tabs
While Right(sTemp, 1) = Chr(9)
sTemp = Left(sTemp, Len(sTemp) - 1)
Wend
Print #1, sTemp
Next r
Close #1
End Sub
Like I mentioned in the above comment this is the fastest way you can export those ranges to text file. No looping required...
Untested
Dim Thiswb As Workbook, thatWb As Workbook
Sub Sample()
Set Thiswb = ThisWorkbook
Set thatWb = Workbooks.Add
CopyRange Thiswb.Sheets("Sheet1"), Thiswb.Sheets("Sheet1").Range("A1:E10000")
CopyRange Thiswb.Sheets("Sheet2"), Thiswb.Sheets("Sheet2").Range("A1:F10000")
CopyRange Thiswb.Sheets("Sheet3"), Thiswb.Sheets("Sheet3").Range("A1:C10000")
Application.DisplayAlerts = False
thatWb.SaveAs "C:\Temp.csv", xlCSV
Application.DisplayAlerts = True
End Sub
Sub CopyRange(ws As Worksheet, rng As Range)
Dim lRow As Long
lRow = thatWb.Sheets(1).Range("A" & thatWb.Sheets(1).Rows.Count).End(xlUp).Row + 1
rng.Copy thatWb.Sheets(1).Range("A" & lRow)
End Sub
Followup from comments
Siddharth this is usful but wont work for me, as my above code plugs in to SQL and JAVA, can you show me how to modify my above code to perform multipul ranges on different sheet regardless of this been the best methord, unfortunatly im not very good with VBA :( – Windmill 5 mins ago
Is this what you are trying? (Untested)
Sub Sample()
Dim Thiswb As Workbook
Set Thiswb = ThisWorkbook
Export Thiswb.Sheets("Sheet1").Range("A2:E50")
Export Thiswb.Sheets("Sheet2").Range("A2:F60")
Export Thiswb.Sheets("Sheet4").Range("A2:C45")
End Sub
Sub Export(rng As Range)
Dim r As Range, c As Range
Dim sTemp As String
'~~> Use Append instead of Output
Open Workbooks("Test.xlsm").Path & "\Test.SQL" For Append As #1
For Each r In rng.Rows
sTemp = ""
For Each c In r.Cells
sTemp = sTemp & c.Text & Chr(9)
Next c
'Get rid of trailing tabs
While Right(sTemp, 1) = Chr(9)
sTemp = Left(sTemp, Len(sTemp) - 1)
Wend
Print #1, sTemp
Next r
Close #1
End Sub
Related
I'm currently working on workbook where in column A:A of worksheet("STAM-Filialen") nearly all the names of the other worksheets are. I want only those worksheets named in column("A:A") in a single PDF. The code I use know makes it a separate file for each worksheet. Is it possible to use a sort of a same code to save it as a single PDF?
Dim myCell As Range
Dim lastCell As Long
Dim PathName As String
lastCell = lastRow("STAM-Filialen")
PathName = Range("I10").Value
Worksheets("STAM-Filialen").Activate
For Each myCell In ThisWorkbook.Worksheets("STAM-Filialen").Range("A2:A" & lastCell).Cells
Dim wksName As String
wksName = myCell.Text
ThisWorkbook.Worksheets(wksName).Range("A1:P60").ExportAsFixedFormat Type:=xlTypePDF, Filename:=PathName & "DispoPlan.Filiaal " & wksName & ".PDF"
Next
I'd recommend moving all the values to a single sheet to print. Then delete this temporary sheet when done.
Here's an example of placing each range from each sheet side by side in a new sheet.
Option Explicit
Public Sub CreateSinglePDF()
Dim ws As Range: Set ws = ThisWorkbook.Sheets(1).Range("A1:A4")
Dim rangeDict As Object: Set rangeDict = CreateObject("Scripting.Dictionary")
Dim cell As Range
For Each cell In ws
If Not rangeDict.exists(cell.Value) And cell.Value <> "" Then
rangeDict.Add cell.Value, ThisWorkbook.Sheets(cell.Value).Range("A1:A5")
End If
Next
Dim printsheet As Worksheet
Set printsheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
Dim key As Variant
Dim i As Long: i = 1
For Each key In rangeDict
printsheet.Range(printsheet.Cells(1, i), printsheet.Cells(5, i)).Value = rangeDict(key).Value
i = i + 1
Next
printsheet.UsedRange.ExportAsFixedFormat Type:=xlTypePDF, Filename:="C:\users\ryan\desktop\ExampleFile.pdf"
printsheet.Delete
End Sub
To convert multiple sheets into single pdf document,
first select multiple sheets
and use the Activesheet.ExportAsFixedFormat statement.
The print range of the page can be set in Page Setup.
Code
Sub test()
Dim WB As Workbook
Dim Ws As Worksheet
Dim sht As Worksheet
Dim PathName As String
Dim vWs() as String '<~~ Variable change
Dim rngDB As Range, rng As Range
Dim n As Integer
Set WB = ThisWorkbook
Set Ws = WB.Worksheets("STAM-Filialen")
PathName = Range("I10").Value
With Ws
Set rngDB = .Range("a1", .Range("a" & Rows.Count).End(xlUp))
End With
For Each rng In rngDB
n = n + 1
ReDim Preserve vWs(1 To n)
vWs(n) = rng.text '<~~ text
Set sht = Sheets(rng.Value)
With sht.PageSetup
.PrintArea = "a1:p60"
End With
Next rng
Sheets(vWs).Select '<~~ multiple sheets select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:=PathName & "DispoPlan.Filiaal.PDF"
End Sub
Worksheets("STAM-Filialen")
Specipic Sheets selected
Single pdf
I have excel file with two worksheets, one with the list of units, second with the lists needed for data validation. I need to split this file into multiple files, and each of them should have only specific unit in the first worksheet, and second worksheet should be intact.
I have found below code, however it creates the file with only first worksheet. Any advice how I can keep another one?
Sub ExportDatabaseToSeparateFiles()
'Export is based on the value in the KeyCol
Dim myCell As Range
Dim mySht As Worksheet
Dim myName As String
Dim myArea As Range
Dim myShtName As String
Dim KeyCol As String
Dim myField As Integer
myShtName = ActiveSheet.Name
KeyCol = "C"
Set myArea = Intersect(ActiveSheet.UsedRange, Range(KeyCol & "1").EntireColumn).Cells
Set myArea = myArea.Offset(1, 0).Resize(myArea.Rows.Count - 1, 1)
myField = myArea.Column - myArea.CurrentRegion.Cells(1).Column + 1
For Each myCell In myArea
On Error GoTo NoSheet
myName = Worksheets(myCell.Value).Name
GoTo SheetExists:
NoSheet:
Set mySht = Worksheets.Add(Before:=Worksheets(1))
mySht.Name = myCell.Value
With myCell.CurrentRegion
.AutoFilter Field:=myField, Criteria1:=myCell.Value
.SpecialCells(xlCellTypeVisible).Copy _
mySht.Range("A1")
mySht.Cells.EntireColumn.AutoFit
.AutoFilter
End With
Resume
SheetExists:
Next myCell
For Each mySht In ActiveWorkbook.Worksheets
If mySht.Name = myShtName Then
Exit Sub
Else
mySht.Move
ActiveWorkbook.SaveAs ActiveSheet.Name & ".xls"
ActiveWorkbook.Close
End If
Next mySht
End Sub
I have some csv files in one folder. They all contain 3 specific columns. The number of total columns and the order may vary.
I want to concatenate all 3 columns with an underscore and write them in a single column in the worksheet that is running the code.
Here is what I have so far:
Option Explicit
Sub test()
Dim i As Long
Dim LastRow As Long
Dim Columns()
Columns = Array("Column1", "Column2", "Column3")
'Find Columns by Name
For i = 0 To 2
Columns(i) = Rows(1).Find(What:=Columns(i), LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False).Column
Next i
'Debug.Print Columns(0)
'Debug.Print Columns(1)
'Debug.Print Columns(2)
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
Cells(i, 1) = Cells(i, Columns(0)) & "_" & Cells(i, Columns(1)) & "_" & Cells(i, Columns(2))
Next i
End Sub
As you can see, this does what I want, but only for the active sheet.
I actually want to loop through all csv files in the same folder as the active sheet and write the results in the first sheet, first column of the sheet running the code (which is not a csv itself obviously).
How can I do this?
thanks!
This is a code that will loop through a folder
Sub Button1_Click()
Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Set Wb = ThisWorkbook
'change the address to suite
MyDir = "C:\WorkBookLoop\"
MyFile = Dir(MyDir & "*.xls") 'change file extension
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
Do While MyFile <> ""
Workbooks.Open (MyFile)
'do something here
MyFile = Dir()
Loop
End Sub
It depends how you are naming the worksheets you create from the CSV files. You could add all the worksheets to a collection and use a For...Each loop to execute the entire search and concatenate procedure within that loop. Note that you'd have to explicitly define the first sheet name as this won't change through successive loops:
Option Explicit
Sub test()
Dim i As Long
Dim LastRow As Long
Dim Columns()
Dim frontSheet as Worksheet
Dim wSheets as New Collection
Dim ws as Worksheet
Set frontSheet = Sheets("name of front sheet")
'Add all your CSV sheets to wSheets using the .Add() method.
For Each ws in wSheets
Columns = Array("Column1", "Column2", "Column3")
'Find Columns by Name
For i = 0 To 2
Columns(i) = ws.Rows(1).Find(What:=Columns(i), LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False).Column
Next i
'Debug.Print Columns(0)
'Debug.Print Columns(1)
'Debug.Print Columns(2)
LastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
frontsheet.Cells(i, 1) = ws.Cells(i, Columns(0)) & "_" & ws.Cells(i, Columns(1)) & "_" & ws.Cells(i, Columns(2))
Next i
Next ws
End Sub
It's often slow and labourious to open CSV files in excel but VBA can read them as text files using a TextStream. Furthermore, file scripting objects let you work with files and directories directly. Something like this might be a better approach if you don't need to keep the files in a worksheet afterwards:
Sub SearchFoldersForCSV()
Dim fso As Object
Dim fld As Object
Dim file As Object
Dim ts As Object
Dim strPath As String
Dim lineNumber As Integer
Dim lineArray() As String
Dim cols() As Integer
Dim i As Integer
Dim frontSheet As Worksheet
Dim frontSheetRow As Integer
Dim concatString As String
Set frontSheet = Sheets("name of front sheet")
frontSheetRow = 1
strPath = "C:\where-im-searching\"
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(strPath)
For Each file In fld.Files
If (Right(file.Name, 3) = "csv") Then
Debug.Print file.Name
Set ts = file.OpenAsTextStream()
lineNumber = 0
Do While Not ts.AtEndOfStream
lineNumber = lineNumber + 1
lineArray = Split(ts.ReadLine, ",")
If (lineNumber = 1) Then
'We are at the first line of the .CSV so
'find index in lineArray of columns of interest
'Add extra ElseIf as required
For i = LBound(lineArray) To UBound(lineArray)
If lineArray(i) = "Column 1" Then
cols(1) = i
ElseIf lineArray(i) = "Column 2" Then
cols(2) = i
ElseIf lineArray(i) = "Column 3" Then
cols(3) = i
End If
Next i
Else
'Read and store the column of interest from this
'row by reading the lineArray indices found above.
concatString = ""
For i = LBound(cols) To UBound(cols)
concatString = concatString & lineArray(i) & "_"
Next i
concatString = Left(concatString, Len(concatString) - 1)
frontSheet.Cells(frontSheetRow, 1).Value = concatString
frontSheetRow = frontSheetRow + 1
End If
Loop
ts.Close
End If
Next file
End Sub
You can find more information on FileSystemObject and TextStream here.
I'm used to write the content (values) of a range of cells to a text file with the write command in VBA, for example:
write #myfile, Range("A1").value, Range("A2).value, Range("A3).value
Does there exist a more elegant and convenient built-in method to dump a whole range directly to a delimited file, possibly even over multiple rows at a time? Or has anybody come up with a customized solution? I think that would be incredibly useful.
I wrote you this it could still be improved, but I think it's good enough:
Sub SaveRangeAsCSV(r As Range, filename As String, overwrite As Boolean)
Dim wB As Workbook
Dim c As Range
Dim usedRows As Long
If overwrite Then
If Dir(filename) <> "" Then Kill filename
If Err.Number <> 0 Then
MsgBox "Could not delete previously existing file." & vbNewLine & Err.Number & ": " & Err.Description
Exit Sub
End If
End If
If Dir(filename) <> "" Then
Set wB = Workbooks.Open(filename)
Else
Set wB = Workbooks.Add
End If
With wB.Sheets(1)
usedRows = .UsedRange.Rows.Count
'Check if more than 1 row is in the used range.
If usedRows = 1 Then
'Since there's only 1 row, see if there's more than 1 cell.
If .UsedRange.Cells.Count = 1 Then
'Since there's only 1 cell, check the contents
If .Cells(1, 1) = "" Then
'you're dealing with a blank workbook
usedRows = 0
End If
End If
End If
'Check if range is contigious
If InStr(r.Address, ",") Then
For Each c In r.Cells
.Range(c.Address).Offset(usedRows, 0).Value = c.Value
Next
Else
.Range(r.Address).Offset(usedRows, 0).Value = r.Value
End If
End With
wB.SaveAs filename, xlCSV, , , , False
wB.Saved = True
wB.Close
End Sub
Sub Example()
'I used Selection here just to make it easier to test.
'Substitute your actual range, and actual desired filepath
'If you pass false for overwrite, it assumes you want to append
'It will give you a pop-up asking if you want to overwrite, which I could avoid
'by copying the worksheet and then closing and deleting the file etc... but I
'already spent enough time on this one.
SaveRangeAsCSV Selection, "C:\proofOfConcept.csv", False
End Sub
When using it, just supply the actual range, the actual filename, and whether or not you want to overwrite the file. :) This has been updated to allow non-contiguous ranges. For merged cells it will end up putting the value in the first cell of the merged range.
This is the solution I came up with by myself and suits my needs best as far as I can see:
Sub DumpRangeToTextFile(filehandle As Integer, source As Range)
Dim row_range As Range, mycell As Range
For Each row_range In source.rows
For Each mycell In row_range.cells
Write #filehandle, mycell.Value;
Next mycell
Write #filehandle,
Next row_range
End Sub
Short and sweet! ;)
Still I'm giving Daniel Cook's solution which is also very useful the credit it deserves.
These methods above iterate across the cell ranges in order to export the data. Anything that tends to do with looping over a range of cells in the sheet is extremely slow due to all the error checking.
Here's a way I did it without the iteration. Basically, it makes use of the built in function "Join()" to do the heavy lifting which would be your iteration loop. This is much faster.
The related Read() subroutine I detailed in another posting: https://stackoverflow.com/a/35688988/2800701
This is the Write() subroutine (note: this assumes your text is pre-formatted to the correct specification in the worksheet before you export it; it will only work on a single column...not on multiple column ranges):
Public Sub WriteRangeAsPlainText(ExportRange As Range, Optional textfilename As Variant)
If IsMissing(textfilename) Then textfilename = Application.GetSaveAsFilename(FileFilter:="Text Files (*.txt), *.txt")
If textfilename = "" Then Exit Sub
Dim filenumber As Integer
filenumber = FreeFile
Open textfilename For Output As filenumber
Dim textlines() As Variant, outputvar As Variant
textlines = Application.Transpose(ExportRange.Value)
outputvar = Join(textlines, vbCrLf)
Print #filenumber, outputvar
Close filenumber
End Sub
From my article Creating and Writing to a CSV FIle using Excel VBA
This Article provides two VBA code samples to create and write to a CSV file:
Creating a CSV file using the Open For Output as FreeFile.
Creating a CSV file using the FileSystemObject object.
I prefer the latter approach mainly as I am using the FileSystemObject for further coding, for example processing all files in subfolders recursively (though that technique is not used in this article).
Code Notes
This code must be run from a regular VBA Code Module. Otherwise the
code will cause an error if users try to run it from the ThisWorkbook
or Sheet Code panes given the usage of Const.
It is worth noting that the ThisWorkbook and Sheet code sections
should be reserved for Event coding only, "normal" VBA should be run
from standard Code Modules.
Please note that for purposes of the sample code, the file path of the
CSV output file is "hard-coded" as:
C:\test\myfile.csv at the top of the code. You will probably want to set the output file programmatically, for instance as a
function parameter.
As mentioned earlier; For example purposes, this code TRANSPOSES
COLUMNS AND ROWS; that is, the output file contains one CSV row for
each column in the selected range. Normally, CSV output would be
row-by-row, echoing the layout visible on screen, but I wanted to
demonstrate that generating the output by using VBA code provides
options beyond what is available by, for instance, using the Save
As... CSV Text menu option.
Code
Const sFilePath = "C:\test\myfile.csv"
Const strDelim = ","
'Option 1
Sub CreateCSV_Output()
Dim ws As Worksheet
Dim rng1 As Range
Dim X
Dim lRow As Long
Dim lCol As Long
Dim strTmp As String
Dim lFnum As Long
lFnum = FreeFile
Open sFilePath For Output As lFnum
For Each ws In ActiveWorkbook.Worksheets
'test that sheet has been used
Set rng1 = ws.UsedRange
If Not rng1 Is Nothing Then
'only multi-cell ranges can be written to a 2D array
If rng1.Cells.Count > 1 Then
X = ws.UsedRange.Value2
'The code TRANSPOSES COLUMNS AND ROWS by writing strings column by column
For lCol = 1 To UBound(X, 2)
'write initial value outside the loop
strTmp = IIf(InStr(X(1, lCol), strDelim) > 0, """" & X(1, lCol) & """", X(1, lCol))
For lRow = 2 To UBound(X, 1)
'concatenate long string & (short string with short string)
strTmp = strTmp & (strDelim & IIf(InStr(X(lRow, lCol), strDelim) > 0, """" & X(lRow, lCol) & """", X(lRow, lCol)))
Next lRow
'write each line to CSV
Print #lFnum, strTmp
Next lCol
Else
Print #lFnum, IIf(InStr(ws.UsedRange.Value, strDelim) > 0, """" & ws.UsedRange.Value & """", ws.UsedRange.Value)
End If
End If
Next ws
Close lFnum
MsgBox "Done!", vbOKOnly
End Sub
'Option 2
Sub CreateCSV_FSO()
Dim objFSO
Dim objTF
Dim ws As Worksheet
Dim lRow As Long
Dim lCol As Long
Dim strTmp As String
Dim lFnum As Long
Set objFSO = CreateObject("scripting.filesystemobject")
Set objTF = objFSO.createtextfile(sFilePath, True, False)
For Each ws In ActiveWorkbook.Worksheets
'test that sheet has been used
Set rng1 = ws.UsedRange
If Not rng1 Is Nothing Then
'only multi-cell ranges can be written to a 2D array
If rng1.Cells.Count > 1 Then
X = ws.UsedRange.Value2
'The code TRANSPOSES COLUMNS AND ROWS by writing strings column by column
For lCol = 1 To UBound(X, 2)
'write initial value outside the loop
strTmp = IIf(InStr(X(1, lCol), strDelim) > 0, """" & X(1, lCol) & """", X(1, lCol))
For lRow = 2 To UBound(X, 1)
'concatenate long string & (short string with short string)
strTmp = strTmp & (strDelim & IIf(InStr(X(lRow, lCol), strDelim) > 0, """" & X(lRow, lCol) & """", X(lRow, lCol)))
Next lRow
'write each line to CSV
objTF.writeline strTmp
Next lCol
Else
objTF.writeline IIf(InStr(ws.UsedRange.Value, strDelim) > 0, """" & ws.UsedRange.Value & """", ws.UsedRange.Value)
End If
End If
Next ws
objTF.Close
Set objFSO = Nothing
MsgBox "Done!", vbOKOnly
End Sub
I have an Excel 2010 workbook. I need to save the used range of each of its worksheets as a tab-delimited text file with no quotes, with the same filename as the workbook and with an extension given by the worksheet name.
Note that Excel stupidly surrounds a value by quotes whenever it sees a comma, even though the delimiter is a tab; other than that, the normal "Save As" / "Text (Tab delimited)" would be fine.
I would prefer to do that using VBA code from within Excel.
If there is a Python solution, I'd be interested too. But at this point pywin32 support for Python 3 is only experimental, so I am not sure I can use it.
Ok here is a slightly complex routine which I wrote couple of months back for one of my clients. This code exports the Excel Worksheet to a Fixed Width File without QUOTES. Screenshots also attached. I am sure this code can be made even better :)
TRIED AND TESTED
Option Explicit
'~~> Change this to relevant output filename and path
Const strOutputFile As String = "C:\Output.Csv"
Sub Sample()
Dim ws As Worksheet
Dim rng As Range
Dim MyArray() As Long, MaxLength As Long
Dim ff As Long, i As Long, lastRow As Long, LastCol As Long
Dim strOutput As String
On Error GoTo Whoa
Application.ScreenUpdating = False
'~~> Change this to the respective sheet
Set ws = Sheets("Sheet1")
LastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
'~~> Loop through each Column to get the max size of the field
For i = 1 To LastCol
MaxLength = getMaxLength(ws, i)
ReDim Preserve MyArray(i)
MyArray(i) = MaxLength
Next i
ff = FreeFile
'~~> output file
Open strOutputFile For Output As #ff
'~~> Write to text file
With ws
lastRow = .Range("A" & Rows.Count).End(xlUp).Row
For Each rng In .Range("A1:A" & lastRow)
With rng
For i = 1 To UBound(MyArray)
'~~> Insert a DELIMITER here if your text has spaces
strOutput = strOutput & " " & Left(.Offset(0, i-1).Text & _
String(MyArray(i), " "), MyArray(i))
Next i
Print #ff, Mid(Trim(strOutput), 1)
strOutput = Empty
End With
Next rng
End With
LetsContinue:
On Error Resume Next
Close #ff
On Error GoTo 0
Application.ScreenUpdating = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
'~~> Function to get the max size
Public Function getMaxLength(ws As Worksheet, Col As Long) As Long
Dim lastRow As Long, j As Long
getMaxLength = 0
lastRow = ws.Range("A" & ws.Rows.Count).End(-4162).Row
For j = 1 To lastRow
If Len(Trim(ws.Cells(j, Col).Value)) > getMaxLength Then _
getMaxLength = Len(Trim(ws.Cells(j, Col).Value))
Next j
End Function
Open your excel/csv/text
Perform your your required action and then You can saveas using file format as xlTextPrinter
ActiveWorkbook.SaveAs Filename:="Your File Name.txt", FileFormat:=xlTextPrinter, CreateBackup:=False
No need for extra code to replace extra quotes