I'd like to copy a table like this in a word document and extract only the track titles and composers. The selecting of the range goes according to plan:
Dim myCells As Range
With ActiveDocument
Set myCells = .Range(Start:=.Tables(1).Cell(2, 3).Range.Start, _
End:=.Tables(1).Cell(.Tables(1).Rows.Count, 3).Range.End)
myCells.Select
End With
Now, when I copy this selection manually and paste it into notepad, I get exactly what I want:
Title
Composer
Title
Composer
etc.
However, I want to write this selection automatically into a text file. When I try to do this, all content is stuffed in one line of text and little squares (paragraph signs?) pop up everywhere.
How would be I be able to get the result of the manual copying, using VBA?
Try this
Sub Allmusic()
Dim filesize As Integer
Dim FlName As String, tempStr As String
Dim i As Long
Dim MyAr() As String
'~~> Name of Output File
FlName = "C:\Sample.Txt"
'~~> Get a free file handle
filesize = FreeFile()
'~~> Open your file
Open FlName For Output As #filesize
With ActiveDocument
For i = 2 To .Tables(1).Rows.Count
'~~> THIS LINE WILL NOT REFLECT CORRECTLY IN THE BROWSER
'~~> PLEASE REFER TO THE SCREENSHOT OR THE ATTACHED FILE
tempStr = Replace(.Tables(1).Cell(i, 3).Range.Text, "", "")
If InStr(1, tempStr, Chr(13)) Then
MyAr = Split(tempStr, Chr(13))
Print #filesize, MyAr(0)
Print #filesize, MyAr(1)
Else
Print #filesize, tempStr
End If
Print #filesize, ""
Next i
End With
Close #filesize
End Sub
SNAPSHOT
SAMPLE FILE
http://sdrv.ms/Mo7Xel
Download the file and run the procedure Sub Allmusic()
OUTPUT
Related
I am beginning a code that will open a csv file, find specific columns and then copy and paste them into the primary excel workbook.
The csv file will have various headers in potentially different orders as they wer automatically generated. Before trying to copy any information, I want to validate the csv file to make sure all the necessary data is present.
Dim WebImp As Workbook
Dim BackLog As String
Dim col As Long, res As Variant
Dim SearchValue As String
Private Sub CommandButton1_Click()
planned:
MsgBox "Open a valid Web Backlog export.", vbExclamation, "Web Import"
Application.FileDialog(msoFileDialogFilePicker).Show
BackLog = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(1)
Set WebImp = Workbooks.Open(BackLog)
Application.DisplayAlerts = False
Application.ScreenUpdating = False
WebImp.Sheets(1).Activate
SearchValue = "Summary"
res = Application.Match(SearchValue, WebImp.Sheets(1).Rows(1), 0)
If IsError(res) Then
WebImp.Close
MsgBox "File missing necessary data.", vbExclamation, "Missing Data"
GoTo planned
End If
End Sub
This is an example of the headers. Highlighted is the column I am trying to seek, but there is no guarantee it will be in column A in the future.
Currently, my code is defaulting to
error 2042
and determines the file is incorrect, even though a cell with "Summary" is present.
What is wrong with the syntax I have written?
Why is it not grabbing properly?
And what are some potential solutions?
Unless there are additional non-printing characters (which you could identify by testing the Len(WebImp.Sheets(1).Range("A1"), the code should work.
Another way to verify wouldbe using the Range.Find method.
Dim r as Range
Set r = WebImp.Sheets(1).Rows(1)
If r.Find("Summary", LookAt:=xlWhole) Is Nothing Then
If r.Find("Summary") Is Nothing Then
MsgBox "Summary doesn't exist in this row"
Else
MsgBox "Summary exists, with additional non-printed characters."
End If
End If
Before trying to copy any information, I want to validate the csv file to make sure all the necessary data is present.
You could also do this using a stream reader to validate the contents of the csv.
Function FileContainsSummary(filepath$)
' returns the index position of "Summary" in row 1 of the CSV file
'filepath = "C:\debug\test.csv"
Dim contents As String
Dim headers() As String
Dim i As Long
Dim ret
Dim ff As Long
ff = FreeFile()
Open filepath For Binary As ff
contents = Space$(LOF(ff))
' reads the entire file contents:
'Get ff, , contents
'reads only the first line:
Line Input #ff, contents
Close ff
'~~ Let's see if "Summary" exists at all:
' You can remove this block after debugging.
If InStr(contents, "Summary") Then
MsgBox "Exists!"
End If
' ~~ find it's position
headers = Split(contents, ",")
' default value of -1, will return if Summary not found.
ret = -1
For i = LBound(headers) To UBound(headers)
If headers(i) = "Summary" Then
ret = i + 1
GoTo EarlyExit
End If
If InStr(headers(i), "Summary") Then
MsgBox "WARNING: Found, but with additional characters."
ret = i + 1
GoTo EarlyExit
End If
Next
EarlyExit:
FileContainsSummary = ret
End Function
I'm trying to populate on array from a CSV file that has spaces between the words and a second one that I'm trying to populate after I have replaced all the spaces with hyphens.
So the contents of array1 looks like this "Hi there" and the contents of array2 looks like this "Hi-there".
I've tried using the replace(text, old, new) but I'm coming across problems. In a standalone macro with no other subs, it works. If there are any other subs it doesn't, throwing up and error saying "wrong number of arguments or invalid property assignment"
This is the code I've got:
Private Sub import_csv()
Dim file_name As String
Dim fnum As Integer
Dim whole_file As String
Dim lines As Variant
Dim one_line As Variant
Dim num_rows As Long
Dim num_cols As Long
Dim the_array() As String
Dim imported_array() As String
Dim txt As String
Dim R As Long
Dim C As Long
file_name = "test.csv"
'load the file
fnum = FreeFile
Open file_name For Input As fnum
whole_file = Input$(LOF(fnum), #fnum)
Close fnum
'Break the file into lines
lines = Split(whole_file, vbCrLf)
'Dimension the array
num_rows = UBound(lines)
one_line = Split(lines(0), ",")
num_cols = UBound(one_line)
ReDim the_array(num_rows, num_cols)
ReDim imported_array(num_rows, num_cols)
'Copy the data into the arrays
For R = 0 To num_rows
If Len(lines(R)) > 0 Then
one_line = Split(lines(R), ",")
For C = 0 To num_cols
imported_array(R, C) = one_line(C)
txt = one_line(C)
txt = replace(txt, " ", "-") '<----- problem line
the_array(R, C) = txt
Next C
End If
Next R
End Sub
Sorry, but this sounds totally weird to me. You are trying to use Word to do a find/replace in a CSV file? Is that it? Why would you even do that? Here is a typical find/replace in a Word document.
Sub FindAndReplaceFirstStoryOfEachType()
Dim rngStory As Range
For Each rngStory In ActiveDocument.StoryRanges
With rngStory.Find
.Text = "find text"
.Replacement.Text = "I'm found"
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next rngStory
End Sub
That's updating things in the body of a Word document. Now, if you want to do a find/replace in a data file, whether it is a CSV, TXT, or Excel file, you should probably use Excel for this kind of task.
Sub Update_CSV()
Open "C:\test.csv" For Input As #1
c0 = Input(LOF(1), #1)
Close #1
Open "C:\test.csv" For Output As #1
Print #1, Replace(c0, "OLD TEXT", "NEW TEXT")
Close #1
End Sub
I've looked and found a little help so far but I'm stuggling with the for each logic for this Excel Macro I'm trying to make.
Basically I have 4 columns of data. Column A has the name of something and column D has either TRUE or FALSE.
I would like a macro wired to a button that creates a new text file in a given directory named after the content of Col A but only if Col D in that row is labled as "TRUE".
For example if I have the following.
ColA = Test ColD = TRUE
ColA = Test2 ColD = FALSE
ColA = Test3 ColD = TRUE
I will get 2 text files anmed Test.txt and Test3.txt.
I know I need a for each loop to look through the range of a1-d(whatever number) and then when D = True do a SaveAs I guess??
This is the code I have so far (yes I know it's very incomplete but this is as far as my logic got before hitting a wall).
Dim fileName As String
Dim filePath As String
Dim curCell As Object
Dim hideRange As Range
filePath = "C:\ExcelTest\"
hideRange = Range("D1:D1048576")
fileName = *Content of Cell A from this Row*
For Each Row In Range("A1:D1048576")
IF curCell.value In Range hideRange = "TRUE"
Then curCell.SaveAs fileName & ".txt, xlTextWindows
Any help or even pointing me in the right direction would be great. I searched around a bit for some examples and couldn't find anything that really matched what I wanted to do.
You are pretty close, but you are looping one hell of a lot of cells there.
Here is the code to loop the rows, this stops at the last populated cell in the column.
Sub LoopRows()
dim sht as worksheet
set sht = Thisworkbook.Sheets("Name of Worksheet")
'loop from row 1 to the last row containing data
For i = 1 To sht.Range("A:A").End(xlDown).Row
'check the value in column 4 for this row (i)
If sht.Cells(i, 4).Text = "TRUE" Then
CreateFile sht.Cells(i, 1).Value
End If
Next i
End Sub
For writing the file, to keep it simple it would reference Microsoft scripting runtime and do it as follows:
Sub CreateFile(FileName As String)
Dim fso As New FileSystemObject
fso.CreateTextFile "c:\temp\" & FileName & ".txt", True
End Sub
EDIT
I can't see why you aren't getting a file created, my tests work fine for me on a windows machine.
Can you please try the following code alone in a button and see if it opens a text file?
Dim fso As New FileSystemObject
fso.CreateTextFile "c:\temp\testfso.txt"
Shell "C:\WINDOWS\notepad.exe c:\temp\testfso.txt", vbMaximizedFocus
EDIT 2
Try this, and see if it opens the text file..
Sub CreateFile(FileName As String)
Dim fso As New FileSystemObject
Dim fName as String
fName = "c:\temp\" & FileName & ".txt"
fso.CreateTextFile fName, True
Shell "C:\WINDOWS\notepad.exe " & fName, vbMaximizedFocus
End Sub
What you are looking for is something like this:
Sub test()
Dim filePath As String
filePath = "C:\ExcelTest\"
Dim xRow As Variant
For Each xRow In Range("A1:D100").Rows
If xRow(1, 4).Value = "TRUE" Then
Open filePath & xRow(1, 1) & ".txt" For Output As #1
Write #1, xRow(1, 2), xRow(1, 3)
Close #1
End If
Next
End Sub
While it works without errors, I would not use it as it is right now.
If you have any questions, just ask.
EDIT
I've run some tests and noticed windows prevents me to create files inside specific folders... pls try this as a new sub and run it:
Sub testForText()
Open Environ("AppData") & "\Testing.txt" For Output As #1
Write #1, "dada"
Close #1
Shell "notepad.exe " & Environ("AppData") & "\Testing.txt", vbNormalFocus
End Sub
Then tell me if notepad opens up with "Testing.txt"
I have a excel sheet which has data in column A.There are many special characters in the cells.When I save the sheet in .txt format I get inverted commas at the start of each line. I tried both manually and by macro saving the file in .txt format.Why is it so? How to remove them?
I am not able to remove the quotes.
Attaching a pic
I see this question is already answered, but wanted to offer an alternative in case someone else finds this later.
Depending on the required delimiter, it is possible to do this without writing any code. The original question does not give details on the desired output type but here is an alternative:
PRN File Type
The easiest option is to save the file as a "Formatted Text (Space Delimited)" type.
The VBA code line would look similar to this:
ActiveWorkbook.SaveAs FileName:=myFileName, FileFormat:=xlTextPrinter, CreateBackup:=False
In Excel 2007, this will annoyingly put a .prn file extension on the end of the filename, but it can be changed to .txt by renaming manually.
In Excel 2010, you can specify any file extension you want in the Save As dialog.
One important thing to note: the number of delimiters used in the text file is related to the width of the Excel column.
Observe:
Becomes:
This code does what you want.
LOGIC
Save the File as a TAB delimited File in the user temp directory
Read the text file in 1 go
Replace "" with blanks and write to the new file at the same time.
CODE
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Const MAX_PATH As Long = 260
'~~> Change this where and how you want to save the file
Const FlName = "C:\Users\Siddharth Rout\Desktop\MyWorkbook.txt"
Sub Sample()
Dim tmpFile As String
Dim MyData As String, strData() As String
Dim entireline As String
Dim filesize As Integer
'~~> Create a Temp File
tmpFile = TempPath & Format(Now, "ddmmyyyyhhmmss") & ".txt"
ActiveWorkbook.SaveAs Filename:=tmpFile _
, FileFormat:=xlText, CreateBackup:=False
'~~> Read the entire file in 1 Go!
Open tmpFile For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
strData() = Split(MyData, vbCrLf)
'~~> Get a free file handle
filesize = FreeFile()
'~~> Open your file
Open FlName For Output As #filesize
For i = LBound(strData) To UBound(strData)
entireline = Replace(strData(i), """", "")
'~~> Export Text
Print #filesize, entireline
Next i
Close #filesize
MsgBox "Done"
End Sub
Function TempPath() As String
TempPath = String$(MAX_PATH, Chr$(0))
GetTempPath MAX_PATH, TempPath
TempPath = Replace(TempPath, Chr$(0), "")
End Function
SNAPSHOTS
Actual Workbook
After Saving
Ummm, How about this.
Copy your cells.
Open Notepad.
Paste.
Look no quotes, no inverted commas, and retains special characters, which is what the OP asked for. Its also delineated by carriage returns, same as the attached pict which the OP didn't mention as a bad thing (or a good thing).
Not really sure why a simple answer, that delivers the desired results, gets me a negative mark.
I just spent the better part of an afternoon on this
There are two common ways of writing to a file, the first being a direct file access "write" statement. This adds the quotes.
The second is the "ActiveWorkbook.SaveAs" or "ActiveWorksheet.SaveAs" which both have the really bad side effect of changing the filename of the active workbook.
The solution here is a hybrid of a few solutions I found online. It basically does this:
1) Copy selected cells to a new worksheet
2) Iterate through each cell one at a time and "print" it to the open file
3) Delete the temporary worksheet.
The function works on the selected cells and takes in a string for a filename or prompts for a filename.
Function SaveFile(myFolder As String) As String
tempSheetName = "fileWrite_temp"
SaveFile = "False"
Dim FilePath As String
Dim CellData As String
Dim LastCol As Long
Dim LastRow As Long
Set myRange = Selection
'myRange.Select
Selection.Copy
'Ask user for folder to save text file to.
If myFolder = "prompt" Then
myFolder = Application.GetSaveAsFilename(fileFilter:="XML Files (*.xml), *.xml, All Files (*), *")
End If
If myFolder = "False" Then
End
End If
Open myFolder For Output As #2
'This temporarily adds a sheet named "Test."
Sheets.Add.Name = tempSheetName
Sheets(tempSheetName).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
LastCol = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
LastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
For i = 1 To LastRow
For j = 1 To LastCol
CellData = CellData + Trim(ActiveCell(i, j).Value) + " "
Next j
Print #2, CellData; " "
CellData = ""
Next i
Close #2
'Remove temporary sheet.
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
'Indicate save action.
MsgBox "Text File Saved to: " & vbNewLine & myFolder
SaveFile = myFolder
End Function
The answer from this question provided the answer to this question much more simply.
Write is a special statement designed to generate machine-readable
files that are later consumed with Input.
Use Print to avoid any fiddling with data.
Thank you user GSerg
I have the same problem: I have to make a specific .txt file for bank payments out of an excel file. The .txt file must not be delimeted by any character, because the standard requires a certain number of commas after each mandatory field.
The easiest way of doing it is to copy the contect of the excel file and paste it in notepad.
I was using Write #1 "Print my Line" instead I tried Print #1, "Print my Line" and it give me all the data without default Quote(")
Dim strFile_Path As String
strFile_Path = ThisWorkbook.Path & "\" & "XXXX" & VBA.Format(VBA.Now, "dd-MMM-yyyy hh-mm") & ".txt"
Open strFile_Path For Output As #1
Dim selectedFeature As String
For counter = 7 To maxNumberOfColumn
selectedFeature = "X"
Print #1, selectedFeature
'Write #1, selectedFeature
Next counter
Close #1
PRN solution works only for simple data in the cells, for me it cuts only first 6 signs from 200 characters cell.
These are the main file formats in Excel 2007-2016,
Note: In Excel for the Mac the values are +1
51 = xlOpenXMLWorkbook (without macro's in 2007-2016, xlsx)
52 = xlOpenXMLWorkbookMacroEnabled (with or without macro's in 2007-2016, xlsm)
50 = xlExcel12 (Excel Binary Workbook in 2007-2016 with or without macro's, xlsb)
56 = xlExcel8 (97-2003 format in Excel 2007-2016, xls)
From XlFileFormat FileFormat Property
Keep in mind others FileFormatNumbers for SaveAs method:
FileExtStr = ".csv": FileFormatNum = 6
FileExtStr = ".txt": FileFormatNum = -4158
FileExtStr = ".prn": FileFormatNum = 36
I want to show 7000 files content that are in a folder and in excel?
I have a found a piece of code that helped me but its only reading one by one. However, I want to read 7000 all in one go. Please help.
Option Explicit
Sub Import_TXT_File()
Dim strg As Variant
Dim EntireLine As String
Dim FName As String
Dim i As String
Application.ScreenUpdating = False
FName = Application.GetOpenFilename("Text Files (*.txt), *.txt", , "Choose File to Import")
Open FName For Input Access Read As #1
i = 1
While Not EOF(1)
Line Input #1, EntireLine
strg = EntireLine
'Change "Sheet1" to relevant Sheet Name
'Change "A" to the relevant Column Name
Sheets("Sheet1").Range("A" & i).Value = strg
i = i + 1
Wend
EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
Close #1
End Sub
user1185158
The code which you are using will be very slow when you are reading 7000 files. Also there is no code which can read 7000 files in 1 go. You will have to loop through the 7000 files. However there is one good news :) Instead of looping through every line in the text file, you can read the entire file into an array and then write it to excel. For example see this code which is very fast as compared to the code that you have above.
TRIED AND TESTED
Sub Sample()
Dim MyData As String, strData() As String
Open "C:\MyFile.Txt" For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
strData() = Split(MyData, vbCrLf)
End Sub
Now using the same code in a loop we can write it into an Excel File
'~~> Change this to the relevant path
Const strPath As String = "C:\Temp\"
Sub Sample()
Dim ws As Worksheet
Dim MyData As String, strData() As String
Dim WriteToRow As Long, i As Long
Dim strCurrentTxtFile As String
Set ws = Sheets("Sheet1")
'~~> Start from Row 1
WriteToRow = 1
strCurrentTxtFile = Dir(strPath & "*.Txt")
'~~> Looping through all text files in a folder
Do While strCurrentTxtFile <> ""
'~~> Open the file in 1 go to read it into an array
Open strPath & strCurrentTxtFile For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
strData() = Split(MyData, vbCrLf)
'~~> Read from the array and write to Excel
For i = LBound(strData) To UBound(strData)
ws.Range("A" & WriteToRow).Value = strData(i)
WriteToRow = WriteToRow + 1
Next i
strCurrentTxtFile = Dir
Loop
MsgBox "Done"
End Sub
What the above code does is that it reads the contents of the 7000 text files in sheet 1 (one below the other). Also I have not included error handling. Please do that.
CAUTION: If you are reading heavy text files, say, each file has 10000 lines then you will have to tweak the code in the above scenario as you will get errors. for example
7000 Files * 10000 lines = 70000000 lines
Excel 2003 has 65536 rows and Excel 2007/2010 has 1048576 rows.
So once the WriteRow reaches the maximum row, you might want to read the text file contents into Sheet 2 and so on...
HTH
Sid
Taking Siddharth's solution a little further. You probably don't want to write each row one at a time, calls to the worksheet are extremely slow in Excel, it is better to do any looping in memory and write back in one fell swoop :)
Sub Sample()
Dim ws As Worksheet
Dim MyData As String, strData() As String, strData2() As String
Dim WriteToRow As Long, i As Long
Dim strCurrentTxtFile As String
Set ws = Sheets("Sheet1")
'~~> Start from Row 1
WriteToRow = 1
strCurrentTxtFile = Dir(strPath & "*.Txt")
'~~> Looping through all text files in a folder
Do While strCurrentTxtFile <> ""
'~~> Open the file in 1 go to read it into an array
Open strPath & strCurrentTxtFile For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
strData = Split(MyData, vbCrLf)
'Resize and transpose 1d array to 2d
ReDim strData2(1 To UBound(strData) + 1, 1 To 1)
For i = 1 To UBound(strData)
strData2(i, 1) = strData(i - 1)
Next i
Sheet1.Range("A1").Offset(Sheet1.Rows.Count - 1, 0).End(xlUp).Offset(1).Resize(UBound(strData), 1).Value = strData2
strCurrentTxtFile = Dir
Loop
MsgBox "Done"
End Sub