VBA: Is there a way to save a list of a combobox to a .txt file?
I did this one here that puts the information of a txt file into a combobox
Dim InFile As Integer
InFile = FreeFile
Open "MYFILE.txt" For Input As InFile
While Not EOF(InFile)
Line Input #InFile, NextTip
ComboBox1.AddItem NextTip
ComboBox1.ListIndex = 0
Wend
Close InFile
The following macro will print a list of items from the specified combobox to the specified text file. Change the name of the macro, and the path and file name for the destination file, accordingly.
'Force the explict declaration of variables
Option Explicit
Private Sub CommandButton1_Click()
'Declare the variables
Dim destFile As String
Dim fileNum As Long
Dim i As Long
'Assign the path and file name for the destination file (change accordingly)
destFile = "C:\Users\Domenic\Desktop\sample.txt"
'Get the next available file number
fileNum = FreeFile()
'Print list items from combobox to destination file
Open destFile For Output As #fileNum
With Me.ComboBox1
For i = 0 To .ListCount - 1
Print #fileNum, .List(i)
Next i
End With
Close #fileNum
MsgBox "Completed!", vbExclamation
End Sub
Related
What I want to do: I have an Log.txt where special values from an Excel-Sheet are listed. Anytime the Macro is executed, it checks for new special values. Before adding them to the Log.txt via a Sub, the same Sub checks if the corresponding value (they are unambigous) is already on the Log-List. If this is not the case, the value should be added to the list.
My approach: You can see my current approach in the code example below.
Dim FileNum as Integer
dim DataLine as String
Dim strPath as String
Dim strEntry as String
strPath = [Path to Log.txt]
strEntry = [Special Value]
'In this first part the Log.txt is opened for Input and each line is saved in DataLine
'to be compared to the special value in strEntry. If it is already in the Log.txt, the Sub to
'create a new Log-Entry is exited and is started again, once the next special value from another cell is
'obtained (from another Sub).
FileNum = FreeFile()
Open strPath For Input As #FileNum
Do While Not EOF(FileNum)
Line Input #FileNum, DataLine
'The value strEntry should start at position 2 of the Entry in the Log.txt (due to the quotation marks [""] in the
'Log.txt line.
If InStr(DataLine, strEntry) = 2 Then Exit Sub
Loop
Close #FileNum
'After it could be verified, that strEntry is not already in the Log.txt, the txt-File should be opened
'again, this time for Append. Then, the strEntry should be written to the txt-File, the Log.txt should close and
'Sub is finished.
FileNum = FreeFile()
Open strPath For Append As #FileNum
Write #FileNum, strEntry
Close #FileNum
The Problem: I observed, that the first part of the Sub is working fine. If strEntry is already in the Log.txt, the Sub is exited and the whole Macro is jumping to the next special value. If this value is not already in the txt-File, the first part of the Sub does not exit the Sub and it jumps to the second part, where it should append the value to the Log.txt.
This is where the problem is. If I exclude the first part of the Sub, I could verify, that the second part is also working fine (as he simply appends all values to the txt-File). But once I have the first part included, I get the Error-Message
File already open.
I can not figure out, why this is happening, as I Close #FileNum at the end of part one.
I thank in advance for your ideas and solutions.
The problem is If InStr(DataLine, strEntry) = 2 Then Exit Sub You are not closing the file in this case as it is exiting the Sub. In this case file remains open. Use Exit Sub judiciously. Try and have one entry point and one exit point so that you can dispose objects/variables and do relevant cleanup correctly.
One way: Using a Boolean Variable
'
'~~> Rest of your code
'
Dim continue As Boolean: continue = True
'
'~~> Rest of your code
'
Do While Not EOF(FileNum)
Line Input #FileNum, DataLine
If InStr(DataLine, strEntry) = 2 Then
continue = False
Exit Do
End If
Loop
Close #FileNum
If continue = True Then
FileNum = FreeFile()
Open strPath For Append As #FileNum
Write #FileNum, strEntry
Close #FileNum
End If
Another way: Using GOTO
FileNum = FreeFile()
Open strPath For Input As #FileNum
Do While Not EOF(FileNum)
Line Input #FileNum, DataLine
'The value strEntry should start at position 2 of the Entry in the Log.txt (due to the quotation marks [""] in the
'Log.txt line.
If InStr(DataLine, strEntry) = 2 Then GoTo CleanupAndExit
Loop
Close #FileNum
'After it could be verified, that strEntry is not already in the Log.txt, the txt-File should be opened
'again, this time for Append. Then, the strEntry should be written to the txt-File, the Log.txt should close and
'Sub is finished.
FileNum = FreeFile()
Open strPath For Append As #FileNum
Write #FileNum, strEntry
CleanupAndExit:
Close #FileNum
I am a technical writer and not much of a coder, I have thousands of .xml files that combined create a book. I used a VBA script from this website to rename all of the files to fit within the new guidelines, now I need to go into the xml code and find all references to those links and replace them with the new file name.
I have an excel spreadsheet where in column A it has the old file name and in column B it has the new file name.
The tag looks like this:
<?iads.link docref="R381"?>
It needs to find "R381" in column A and replace it with "R01081-1-1520-237", the file name in the adjacent cell in column B.
The Tag needs to look like this:
<?iads.link docref="R01081-1-1520-237"?>
I tried using the code from the question How can I Find/Replace multiple strings in an xml file? but it did not work and I'm not even sure if that's the correct question to be asking
My current code looks lie this:
Option Explicit ' Use this !
Public Sub ReplaceXML(rFindReplaceRange As Range) ' Pass in the find-replace range
Dim sBuf As String
Dim sTemp As String
Dim iFileNum As Integer
Dim sFileName As String
Dim i As Long
' Edit as needed
sFileName = "C:\Users\s37739\Desktop\chap3"
iFileNum = FreeFile
Open sFileName For Input As iFileNum
Do Until EOF(iFileNum)
Line Input #iFileNum, sBuf
sTemp = sTemp & sBuf & vbCrLf
Loop
Close iFileNum
' Loop over the replacements
For i = 1 To rFindReplaceRange.Rows.Count
If rFindReplaceRange.Cells(i, 1) <> "" Then
sTemp = Replace(sTemp, rFindReplaceRange.Cells(i, 1), rFindReplaceRange(i, 2))
End If
Next i
' Save file
iFileNum = FreeFile
' Alter sFileName first to save to a different file e.g.
sFileName = "C:\Users\s37739\Desktop\chap3"
Open sFileName For Output As iFileNum
Print #iFileNum, sTemp
Close iFileNum
End Sub
Sub mike1()
End Sub
You are passing the file path when in fact you should be passing the fully qualified file name (file path and file name).
You need to edit those lines
' Edit as needed
sFileName = "C:\Users\s37739\Desktop\chap3"
'...
' Alter sFileName first to save to a different file e.g.
sFileName = "C:\Users\s37739\Desktop\chap3"
With
' Edit as needed
sFileName = "C:\Users\s37739\Desktop\chap3\yourfilename.xml"
'...
' Alter sFileName first to save to a different file e.g.
sFileName = "C:\Users\s37739\Desktop\chap3\yourNEWfilename.xml"
Also, remember to provide the correct Range when running the procedure.
Supposing your Range goes from "A1:B50" you can edit your mike1 sub as follows:
Sub mike1()
' Change range as desired
Call ReplaceXML(ThisWorkbook.Worksheets("YourSheetName").Range("A1:B50"))
End Sub
After that, all you need to do is run mike1 from the Immediate window.
Access using Alt+F11 for the VBA editor then View -> Immediate.
You should see a new window at the bottom of the screen. Just type mike1 in there and hit Enter
UPDATE:
Ideally, you should first try to understand the code you currently have and change it make it work on multiple files instead of a single one per run. There are many places around that can give you examples on how to do that, either recursively or in a loop directly into a function. There are many ways to do it and also many material around it.
That being said, you can find below one of the many approaches to solve your issue. The following code consists of two Subs that you can copy/paste into your module.
You need to change the value of HOST_PATH with the main folder and the findReplaceRange with the range to work with. You need to change "Sheet1" with the name of your worksheet and the "A1:B10" with your actual range. After that, just run the ReplaceXML2() Sub.
Note: this will update ALL XML files under the folder provided, so make sure you gave it enough testing (preferably, backup your files) before running it for the entire folder. If you have further issues I suggest asking another question.
Code:
Public Sub ReplaceXML2()
Const HOST_PATH = "C:\Users\s37739\Desktop\chap3\" ' change accordingly
Dim findReplaceRange As Range
Set findReplaceRange = ThisWorkbook.Worksheets("Sheet1").Range("A1:B10") ' change accordingly
Dim FileSystem As Object
Set FileSystem = CreateObject("Scripting.FileSystemObject")
Call RecursivelyReplaceXML(FileSystem.GetFolder(HOST_PATH), findReplaceRange)
End Sub
Public Sub RecursivelyReplaceXML(parentFolder, rFindReplaceRange As Range) ' Pass in the folder and the find-replace range
Dim subFolder As Object
For Each subFolder In parentFolder.SubFolders
RecursivelyReplaceXML subFolder, rFindReplaceRange
Next
Dim file As Object
For Each file In parentFolder.Files
If Right(file.Name, 4) = ".xml" Then
Dim iFileNum As Integer
Dim sTemp As String
Dim sBuf As String
Dim i As Long
Dim fullFileName As String
fullFileName = file.Path
iFileNum = FreeFile
Open fullFileName For Input As iFileNum
sTemp = "" ' clean up to read the next file
Do Until EOF(iFileNum)
Line Input #iFileNum, sBuf
sTemp = sTemp & sBuf & vbCrLf
Loop
Close iFileNum
' Loop over the replacements
For i = 1 To rFindReplaceRange.Rows.count
If rFindReplaceRange.Cells(i, 1) <> "" Then
sTemp = Replace(sTemp, rFindReplaceRange.Cells(i, 1), rFindReplaceRange(i, 2))
End If
Next i
' Save file
iFileNum = FreeFile
' WARNING: New name definition commented out,
' which means all files will be replaced with newer versions!!
'===
' Alter fullFileName first to save to a different file e.g.
' fullFileName = "C:\Users\s37739\Desktop\chap3\"
Open fullFileName For Output As iFileNum
Print #iFileNum, sTemp
Close iFileNum
End If
Next
End Sub
I am trying to achieve a simple objective,insert row count and column count summary of an excel file to an existing notepad.
I have multiple files in a folder and would like to run this operation for each file and send the details to a notepad.
Issue: Every time i run the code it deletes existing content and inserts new data into the notepad. I would like to retain existing data and start appending from a new line
code:
Sub Sndtotxt()
Dim FF
Dim rCnt AS INTEGER
Dim cCnt AS INTEGER
rCnt = ActiveSheet.UsedRange.Rows.Count
cCnt = ActiveSheet.UsedRange.Columns.Count
FF = FreeFile()
OPEN "C:\Temp files\summaryreport.txt" FOR Output AS #FF
Print #FF, rCnt
Print #FF, cCnt
CLOSE #FF
END Sub
replace
OPEN "C:\Temp files\summaryreport.txt" FOR Output AS #FF
with
OPEN "C:\Temp files\summaryreport.txt" FOR Append AS #FF
In terms of looping through files in a folder, suggest you start with my code from Loop through files in a folder using VBA?
Change the path below for both
Excel files C:\temp\
Txt report C:\Temp\test.txt
to suit
Sub GetEm()
Dim WB As Workbook
Dim StrFile As String
Dim FF
FF = FreeFile()
Open "C:\Temp\test.txt" For Append As #FF
StrFile = Dir("c:\temp\*.xls*")
Do While Len(StrFile) > 0
Set WB = Workbooks.Open("c:\temp\" & StrFile)
StrFile = Dir
Print #FF, WB.Name, WB.Sheets(1).UsedRange.Rows.Count, WB.Sheets(1).UsedRange.Columns.Count
WB.Close
Loop
Close #FF
End Sub
I need to select a text file to import into Excel where the name of the text file contains a string of text that matches a cell in the Excel spreadsheet.
Eg.
A cell with a value "D12345"
I need to import a text file into the sheet where the same string (i.e. "D12345") is contained in the name of the text file.
The selection needs to be made from a collection of text files. Only 1 file in the collection will contain the matching string.
Hope that makes sense.
Give this a try:
Sub SimpleFileListre()
Dim s As String, FileName As String
Dim mesage As String
Range("A:A").Clear
s = "C:\TestFolder\*.txt"
sFolder = "C:\TestFolder\"
FileName = Dir(s)
Do Until FileName = ""
If InStr(1, FileName, "D12345") > 0 Then
Call GetStuff(sFolder & FileName)
End If
FileName = Dir()
Loop
End Sub
Sub GetStuff(s)
Close #2
Open s For Input As #2
j = 1
Do While Not EOF(2)
Line Input #2, TextLine
Cells(j, 1) = TextLine
j = j + 1
Loop
Close #2
End Sub
I have a Google spreadsheet that I need to export and have every field contained in double quotes "field" but at the moment it doesn't not do this.
Is there an easy way to achieve this without resorting to manually editing hundreds of lines?
Max
You can use from excel too using appropiate macro like this:
Sub QuoteCommaExport()
' Dimension all variables.
Dim DestFile As String
Dim FileNum As Integer
Dim ColumnCount As Integer
Dim RowCount As Integer
' Prompt user for destination file name.
DestFile = InputBox("Enter the destination filename" & Chr(10) & "(with complete path):", "Quote-Comma Exporter")
' Obtain next free file handle number.
FileNum = FreeFile()
' Turn error checking off.
On Error Resume Next
' Attempt to open destination file for output.
Open DestFile For Output As #FileNum
' If an error occurs report it and end.
If Err <> 0 Then
MsgBox "Cannot open filename " & DestFile
End
End If
' Turn error checking on.
On Error GoTo 0
' Loop for each row in selection.
For RowCount = 1 To Selection.Rows.Count
' Loop for each column in selection.
For ColumnCount = 1 To Selection.Columns.Count
' Write current cell's text to file with quotation marks.
Print #FileNum, """" & Selection.Cells(RowCount, ColumnCount).Text & """";
' Check if cell is in last column.
If ColumnCount = Selection.Columns.Count Then
' If so, then write a blank line.
Print #FileNum,
Else
' Otherwise, write a comma.
Print #FileNum, ";";
End If
' Start next iteration of ColumnCount loop.
Next ColumnCount
' Start next iteration of RowCount loop.
Next RowCount
' Close destination file.
Close #FileNum
End Sub
I found that you can achieve this by using Open Office. From their you can define your own separators and surrounding characters.
When saving/exporting as a CSV check the box saying define my own characters.