I have multiple worksheets in my workbook.
Each worksheet has two columns of data (ColA and ColC) which I want to print to separate text files.
The attached code results in two text files: “WorksheetTab_LnFn.txt” and “WorksheetTab_FnLn.txt”
The text file saved from my ColA does NOT quotations whilst the second text file saved from my ColC DOES HAVE quotation marks - I want each resulting text file to NOT have quotation marks.
I may have worksheets later with data in ColA, ColC, ColE and ColG, each of which I want to export/save/print to a text file – thus I would want in that case four separate text document, all WITHOUT quotation marks.
The best code I have been able to find is locate is: Write export of selected cells as a .txt file without "quotation marks" and I have looked at How to create a text file using excel VBA without having double quotation marks?.
I understand most of it, but am not being successful at integrating parts of this code into mine. Ideally I am seeking to reduce the code and loop so it would process ColA and then ColB without having two separate code blocks. I did use code I found and made minimal changes, but do not know if the Case LCase line is necessary
'Create FirstName LastName Isolation TXT files
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sh In Sheets
Select Case LCase(sh.Name)
Case LCase("[COLOR=#0000ff]Master[/COLOR]"), LCase("[COLOR=#0000ff]Info[/COLOR]")
Case Else
sh.Range("A:A").Copy
Workbooks.Add
ActiveSheet.Paste
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & sh.Name & "_FnLn.txt", _
FileFormat:=xlTextMSDOS, CreateBackup:=False
ActiveWorkbook.Close False
End Select
Next
'Create LastName FirstName Isolation TXT files
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sh In Sheets
Select Case LCase(sh.Name)
Case LCase("[COLOR=#0000ff]Master[/COLOR]"), LCase("[COLOR=#0000ff]Info[/COLOR]")
Case Else
sh.Range("C:C").Copy
Workbooks.Add
ActiveSheet.Paste
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & sh.Name & "_LnFn.txt", _
FileFormat:=xlTextMSDOS, CreateBackup:=False
ActiveWorkbook.Close False
End Select
Next
MsgBox "Text Files Created"
End Sub
This should do what you want:
Sub Tester()
Dim filename As String, myrng As Range, sh As Worksheet, wb As Workbook
Set wb = ThisWorkbook
For Each sh In wb.Worksheets
filename = wb.Path & "\" & sh.Name & "_FnLn.txt"
Set myrng = sh.Range("C1:C" & sh.Cells(sh.Rows.Count, "C").End(xlUp).Row) 'use sh reference
RangeToTextFile myrng, filename 'comma-separated
'RangeToTextFile myrng, filename, vbtab 'e.g. for tab-separated file
Next
MsgBox "Text Files Created"
End Sub
'write a range `rng` to a text file at `fPath`. Default separator is comma
Sub RangeToTextFile(rng As Range, fPath As String, Optional separator As String = ",")
Dim data, r As Long, c As Long, sep, lo As String, ff As Integer
ff = FreeFile() 'safer than using hard-coded #1
Open fPath For Output As #ff
If rng.Cells.CountLarge = 1 Then
ReDim data(1 To 1, 1 To 1) 'handle special case of single cell
data(1, 1) = rng.Value
Else
data = rng.Value 'get all values as an array
End If
For r = 1 To UBound(data, 1) 'loop rows
lo = "" 'clear line output
sep = "" 'clear separator
For c = 1 To UBound(data, 2) 'loop columns
lo = lo & sep & data(r, c) 'build the line to be written
sep = separator 'add separator after first value
Next c
Print #ff, lo 'write the line
Next r
Close #ff
End Sub
Related
Just need some help. I want to delete multiple sheets using their partial name that I will enter in the input box. Is there any code that I can add multiple partial names in input box so they will be deleted at once?
For example, I would like to add these partial names: "Pivot", "IWS, "Associate", "Split", and "Invoice"
My initial code can delete sheets with just one partial name, sample if I enter "Pivot" it will delete all sheets with "Pivot" name. I want to tweak my code where I can add multiple partial name to the input box.
Here's the initial code:
Sub ClearAllSheetsSpecified()
'----------------------------------------------------------------------------------------------------------
' Clear all sheets specified in input box
'----------------------------------------------------------------------------------------------------------
Dim shName As String
Dim xName As String
Dim xWs As Worksheet
Dim cnt As Integer
shName = Application.InputBox("Enter the sheet name to delete:", "Delete sheets", _
ThisWorkbook.ActiveSheet.Name, , , , , 2)
If shName = "" Then Exit Sub
'**** use LCase() here
xName = "*" & LCase(shName) & "*"
' MsgBox xName
Application.DisplayAlerts = False
cnt = 0
For Each xWs In ThisWorkbook.Sheets
'**** Use LCase() here
If LCase(xWs.Name) Like xName Then
xWs.Delete
'MsgBox xName
cnt = cnt + 1
End If
Next xWs
Application.DisplayAlerts = True
MsgBox "Have deleted " & cnt & " worksheets", vbInformation, "Sheets removed"
I'm looking for a code that I can enter any partial name in my input box then sheets will be deleted as long as they exist in my current WB.
This is a way to capture your list of phrases. The input text must have a common delimiter that you code for. In this case I used the semi-colon.
Sub testIt()
Dim shName As String
Dim xName() As String
Dim cnt As Integer
shName = Application.InputBox("Enter the sheet names (delimited by ;) to delete:", "Delete sheets", _
ThisWorkbook.ActiveSheet.Name, , , , , 2)
If shName = "" Then Exit Sub
'**** use LCase() here
xName = Split(LCase(shName), ";")
For x = 0 To UBound(xName)
Debug.Print "*" & xName(x) & "*"
'do your delete
Next x
End Sub
I´m trying to create a CSV file that will export an Excel Table Column Cell Values, in the following manner:
row number "Tab" cell values
but in the following script it only exports the value of the first cell in the table (the rows number & order is correct) .. How to fix it ?
Private Sub ExportAsCSV()
'Export current sheet as a CSV TXT file on the same location
Dim ThisPathName, CSVFileName, ThisFileName, ThisSheetName As String
Dim SeriesRange As Range
Dim i As Integer
ThisPathName = ThisWorkbook.Path ' Generate workbook current path
ThisFileName = ThisPathName & "/" & ThisWorkbook.Name ' Generate file name & path
ThisSheetName = ActiveSheet.Name ' Generate sheet name
CSVFileName = ThisPathName & "/Wren Kitchens " & ThisSheetName & ".txt"
' Sets CSV txt file name and location
If ActiveSheet.Name = "00 Kitchen Series" Then
'if active table is "00 Kitchen Series"
Open CSVFileName For Output As #1
Set SeriesRange = ActiveSheet.ListObjects("KitchenLinesTable").ListColumns(1).DataBodyRange
For i = 1 To SeriesRange.Count
Print #1, i & " " & ActiveSheet.ListObjects("KitchenLinesTable").DataBodyRange(1, i).Value
Next i
Close #1
End If
End Sub
Please, try the next compact way to create the CSV string:
Replace this code:
If ActiveSheet.Name = "00 Kitchen Series" Then
'if active table is "00 Kitchen Series"
Open CSVFileName For Output As #1
Set SeriesRange = ActiveSheet.ListObjects("KitchenLinesTable").ListColumns(1).DataBodyRange
For i = 1 To SeriesRange.Count
Print #1, i & " " & ActiveSheet.ListObjects("KitchenLinesTable").DataBodyRange(i, 1).Value
Next i
Close #1
End If
End Sub
with the next one:
Set SeriesRange = ActiveSheet.ListObjects("KitchenLinesTable").ListColumns(1).DataBodyRange
Open CSVFileName For Output As #1
Print #1, Join(Application.Transpose(Evaluate("row(1:" & SeriesRange.count & ")&"" ""&" & SeriesRange.Address)), vbCrLf)
Close #1
The arrays VBA part and Evaluate method can be something amazing, if you understand them... I will try showing what is necessary to be known, in order o understand the above code. Open Immediate Window (Ctrl + G, being in VBE) and press F5when code stops (onStop` command) and could see the return:
Sub TestToUnderstandAboveCode()
Dim SeriesRange As Range
Set SeriesRange = ActiveSheet.ListObjects("KitchenLinesTable").ListColumns(1).DataBodyRange
'1. Placing a range in an array:
Dim arr: arr = SeriesRange.Value 'it creates a 2D array
Debug.Print arr(1, 1) 'returns the first array element
'Make the above array 1D:
arr = Application.Transpose(arr)
'or doing it dirrectly:
arr = Application.Transpose(SeriesRange.Value)
'it can be tested so:
Debug.Print Join(arr, "|")
'another way to create an array is using Evaluate (very powerfull method):
arr = Evaluate(SeriesRange.Address) '2D array
arr = Application.Transpose(Evaluate(SeriesRange.Address)) '1D array
Debug.Print Join(arr, "|"): Stop 'it returns the same as above. Press F5 to continue the code
'now we need to build another 1D array to keep the range rows:
Dim arrRows: arrRows = Application.Evaluate("row(1:10)") '2D array keeping numbers from 1 to 10
Debug.Print Join(Application.Transpose(arrRows), "|") 'You can join only a 1D array to see the jonned string
'Now, let us personalize it according to the necessary string to be processed:
arrRows = Application.Transpose(Evaluate("row(1:" & SeriesRange.cells.count & ")"))
Debug.Print Join(arrRows, "|")
'Now, putting all pieces together:
arr = Evaluate("row(1:" & SeriesRange.count & ")&"" ""&" & SeriesRange.Address) 'it creates a 2D array separating arrays by " "
Debug.Print Join(Application.Transpose(arr), "|") ': Stop
'having a 1D array and needing a string having end lines for each array element we need to build it
'for doing it we need to firstly join the array elements by vbCrLf (end of line) separator:
Dim strArr As String
strArr = Join(Application.Transpose(arr), vbCrLf)
Debug.Print strArr : Stop 'it returns the string showing all elemnts one bellow the other.
'and finally doit it at once:
strArr = Join(Application.Transpose(Evaluate("row(1:" & SeriesRange.count & ")&"" ""&" & SeriesRange.Address)), vbCrLf)
Debug.Print strArr
End Sub
Hi here is my generic Sub to export a CSV file inside a folder in the same directory as the workbook, you juste have to send the table name when you call it
ExportTableToCSV("MyTableName")
And it call the following sub
Public Sub ExportTableToCSV(TableName as String)
Dim ws As Worksheet
Dim FilePath, CSVLocation, fol As String
Dim ParseRange As Range
Dim cellValue As Variant
Dim j, k As Integer
Set ws = Application.ActiveSheet
Set ParseRange = ws.ListObjects(TableName).Range
CSVLocation = Application.ActiveWorkbook.Path & "\NewFolder\"
fol = Dir(CSVLocation, vbDirectory)
If fol = "" Then MkDir CSVLocation
FilePath = Application.ActiveWorkbook.Path & "\NewFolder\" & TableName & ".csv"
Open FilePath For Output As #1
For j = 1 To ParseRange.Rows.Count
For k = 1 To ParseRange.Columns.Count
cellValue = ParseRange.Cells(j, k).Value
If k = ParseRange.Columns.Count Then
Write #1, cellValue
Else
Write #1, cellValue,
End If
Next k
Next j
Close #1
End Sub
Many thanks to #FaneDuru for the answer s/he have provided in the comments.
The problem was caused by DataBodyRange(1, i).Value, as Excel understands that it's iterating by the table's rows.
The correct answer must be DataBodyRange(i, 1).Value, so that Excel can iterate by row's indices.
The code corrected:
Private Sub ExportAsCSV()
'Export current sheet as a CSV TXT file on the same location
Dim ThisPathName, CSVFileName, ThisFileName, ThisSheetName As String
Dim SeriesRange As Range
Dim i As Integer
ThisPathName = ThisWorkbook.Path ' Generate workbook current path
ThisFileName = ThisPathName & "/" & ThisWorkbook.Name ' Generate file name & path
ThisSheetName = ActiveSheet.Name ' Generate sheet name
CSVFileName = ThisPathName & "/Wren Kitchens " & ThisSheetName & ".txt"
' Sets CSV txt file name and location
If ActiveSheet.Name = "00 Kitchen Series" Then
'if active table is "00 Kitchen Series"
Open CSVFileName For Output As #1
Set SeriesRange = ActiveSheet.ListObjects("KitchenLinesTable").ListColumns(1).DataBodyRange
For i = 1 To SeriesRange.Count
Print #1, i & " " & ActiveSheet.ListObjects("KitchenLinesTable").DataBodyRange(i, 1).Value
Next i
Close #1
End If
End Sub
Once again, Thank you #FaneDuru
I wonder if anyone can help me.
I have a bunch of text files that contain a few thousand lines, and I just want to extract one element of each file.
A snippet of the contents of the files is like so:
<LastMassUpdateChange xsi:nil="true" />
<Notes />
<PropertyType1>House</PropertyType1>
<PropertyType2>SemiDetached</PropertyType2>
<PositionOfFlat xsi:nil="true" />
<FlatWhichFloor>0</FlatWhichFloor>
<FlatFloorsAbove>0</FlatFloorsAbove>
Where I just want to extract the text between <PropertyType2> & </PropertyType2> So in this case SemiDetached and place this result next to the file url column.
The urls of the files will all be in a column within excel, so I need a loop vba to check each text file within that column, and put the result in the next column.
I had the following code to extract the data within a certain line, but I didn't realise the files were not all formatted with the same amount of lines so it hasn't worked out.
Any help greatly appreciated, thanks.
Sub extractpropertytype()
Dim d As Integer
' For d = 1 To Sheet2.Range("G" & Rows.Count).End(xlUp).Row
For d = 2 To Range("AE1").Value + 1
'Workbooks("Book1").Activate
Open Range("AA" & d).Value For Input Access Read As #1
For i = 1 To 80
Line Input #1, X
'Range("a1").Offset(i - 1, 0).Value = x
Next i
Line Input #1, X
Range("AB" & d) = X
Close #1
Next d
End Sub
This reads all the lines into a string using a file system object and a regular expression to extract the value between the tags.
Option Explicit
Sub extractpropertytype()
Dim wb As Workbook, ws As Worksheet
Dim iRow As Long, iLastRow As Long
Dim sXML As String, sFilename As String, sPath As String
Dim Regex As Object, Match As Object
Set Regex = CreateObject("vbscript.regexp")
' capture text between tags
With Regex
.Global = True
.MultiLine = True
.IgnoreCase = True
.Pattern = "<PropertyType2>(.*)</PropertyType2>"
End With
' file system object to read text
Dim oFSO As Object, oFile As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set wb = ThisWorkbook
Set ws = Sheet2 ' change to suit
sPath = wb.Path & "\"
' scan list of text files on turn
iLastRow = ws.Range("AE1").Value + 1
For iRow = 2 To iLastRow
' open file and read all lines
sFilename = sPath & ws.Cells(iRow, "AA")
Set oFile = oFSO.OpenTextFile(sFilename, 1)
sXML = oFile.ReadAll
' extract value with regex
If Regex.test(sXML) Then
Set Match = Regex.Execute(sXML)
ws.Cells(iRow, "AB") = Match(0).submatches(0)
Else
ws.Cells(iRow, "AB") = "No match"
End If
oFile.Close
Next iRow
MsgBox iLastRow - 1 & " files scanned", vbInformation
End Sub
I am trying to write a Macro in VBA using Excel 2010 that is linked to a button in a worksheet (located in Cell A1). When the button is pressed, a CSV should be generated that deletes columns A and B, so that column C effectively becomes column A. I am trying to also name the newly generated CSV based on the cell contents from cell A30 within the worksheet, but when I run the macro I am getting an error on the SaveAs function. I believe this is because cell A30 is deleted later on in the script. My question is where there is a way to use the Range (A30) to name the new CSV while still deleting that cell later on within the new CSV all within the same sub? I'm still new to VBA, so it is unclear to me why this is an issue when I would think that each command is executed sequentially, so once the CSV is saved with the new name, I would think I'd be able to delete the source of the file name.
Sub rpSaveCSV()
Dim ws As Worksheet
Set ws = ActiveSheet
'Saves current sheet of tracker as a CSV
ws.SaveAs "Y:\Drive\Youth " & Range("A30") & " .csv", FileFormat:=xlCSV
'Copies entire sheet and pastes values to get rid of formulas
ws.Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
ActiveSheet.Select
Application.CutCopyMode = False
'Deletes first two columns and all remaining columns without content
Range("A:B").EntireColumn.Delete
Range("BI:XFD").EntireColumn.Delete
'Saves panel CSV
ActiveWorkbook.Save
'Opens Tracker up again
Workbooks.Open Filename:="Y:\Drive\Tracker.xlsm"
End Sub
Declare a variable to hold the string value:
Dim filename as String
filename = Range("A30")
'verify that "Y:\Drive\Youth " & filename & " .csv" is a valid file name:
Debug.Print "Y:\Drive\Youth " & filename & " .csv" ' looks right? Ctrl+G to find out
ws.SaveAs "Y:\Drive\Youth " & filename & " .csv", FileFormat:=xlCSV
'...delete columns...
'...do stuff...
Debug.Print filename 'value is still here!
I would recommend learning to use arrays with Excel data. It can often be far simpler than trying to replication Excel Application functions in VBA. And it is far more efficient/fast.
Here is a function that feeds the data to an array, and then prints the array to a csv (text) file.
Sub CreateCsvFromWorkSheet(leftColumn, rightColumn, FileName)
Set ws = ActiveSheet
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.CreateTextFile(FileName, True)
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
ar = ws.Range(ws.Cells(1, leftColumn), ws.Cells(lastRow, rightColumn))
For i = 1 To UBound(ar, 1)
strLine = ""
For j = 1 To UBound(ar, 2)
strLine = strLine & ar(i, j) & ","
Next
strLine = Left(strLine, Len(strLine) - 1)
f.WriteLine strLine
Next
f.Close
End Sub
You can call the function like this:
Sub TestRun()
FileName = "Y:\Drive\Youth " & Range("A30") & " .csv"
CreateCsvFromWorkSheet 3, 60, FileName
MsgBox "Complete."
End Sub
I am looking to have my Macro save a new sheet that i created as a .txt file. this is the code i have so far.
Sub Move()
'
' Move Macro
'
' Keyboard Shortcut: Ctrl+m
'
Sheets("Sheet1").Select
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
ActiveWorkbook.SaveAs Filename:="e:" & _
"HDR" + Format(Now(), "YYYYMMDDhhmmss") & ".txt"
End Sub
That includes my macro. I am having trouble with the last part where it saves as a .txt file.
I am currently getting a bunch of crap on my .txt file, here is an example,
"PK ! !}ñU{ Š [Content_Types].xml ¢( ÌTÝNÂ0¾7ñ–Þš€‰1†Á…⥒ˆPÚ3¶ÐµMOÁñöž•Ÿ¨".
Any help would be great.
Manually changing the extension of the file name does not actually change the file type. The SaveAs method takes a file type argument. The code you want is
ActiveWorkbook.SaveAs Filename:="e:" & "HDR" + Format(Now(), "YYYYMMDDhhmmss") _
& ".txt", FileFormat:= xlTextWindows
Doing a search from within Excel help for XlFileFormat will get you (almost) the full list of possible file formats, including 6 text formats, and 4 CSV formats.
Adding txt to the name does not automatically encode the word document into plain text format.
Instead attempt
ActiveWorkbook.SaveAs Filename:="e:" & _
"HDR" + Format(Now(), "YYYYMMDDhhmmss") & ".txt", FileFormat:=wdFormatText, Encoding:=1252
The ActiveWorkbook.SaveAs method adds double quote to the beginning and end of every line in the file.
This method parses each line from a given range and transforms it into a CSV file:
Sub SaveSheetToCSVorTXT()
Dim xFileName As Variant
Dim rng As Range
Dim DelimChar As String
DelimChar = "," 'The delimitation character to be used in the saved file. This will be used to separate cells in the same row
xFileName = Application.GetSaveAsFilename(ActiveSheet.Name, "CSV File (*.csv), *.csv, Text File (*.txt), *.txt")
If xFileName = False Then Exit Sub
If Dir(xFileName) <> "" Then
If MsgBox("File '" & xFileName & "' already existe. Overwrite?", vbYesNo + vbExclamation) <> vbYes Then Exit Sub
Kill xFileName
End If
Open xFileName For Output As #1
'Save range contents. Examples of ranges:
'Set rng = Activesheet.Range("A1:D4") 'A rectangle between 2 cells
'Set rng = Activesheet.columns(1) 'An entire column
Set rng = ActiveSheet.Range("B14").CurrentRegion 'The "region" from a cell. This is the same as pressing CTRL+T on the selected cell
For i = 1 To rng.Rows.Count
For j = 1 To rng.Columns.Count
lineText = IIf(j = 1, "", lineText & DelimChar) & rng.Cells(i, j)
Next j
Print #1, lineText
Next i
Close #1
MsgBox "File saved!"
End Sub