Just like you can copy an arbitrary number of lines from a text document and paste into Excel in successive rows, I want to be able to copy the lines of text and paste them into the comments of successive rows in Excel. To make it a bit easier, I paste the rows of comment text from the .txt file into a column in Excel first. This is what I'm looking at right now:
Dim myClip As New DataObject
Dim myString As String
myClip.GetFromClipboard
myString = myClip.GetText
Sheet1.Range("A1").AddComment myString
but pasting from the clipboard like this doesn't seem to have to the desired effect. Any ideas?
Sub AddCommentsToSelection()
Dim myClip As New DataObject
Dim myString As String
Dim c As Range, arr, x As Integer
myClip.GetFromClipboard
myString = myClip.GetText
If Len(myString) = 0 Then Exit Sub
Set c = Selection.Cells(1)
arr = Split(myString, vbCrLf)
For x = LBound(arr) To UBound(arr)
c.AddComment arr(x)
Set c = c.Offset(1, 0)
Next x
End Sub
Related
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
Is there a way to dump every word and their start range and end range into an array or dictionary or etc. without looping?
I already tried the following two methods and they work,
Sub test_1()
Dim wrd As Variant
Dim TxtArray() As String
Dim i As Long
For Each wrd In ActiveDocument.Range.Words
'code to add to add to array her
Next
End Sub
and
Sub test_2()
Dim TxtArray() As String
TxtArray = Split(ActiveDocument.Range.Text)
End Sub
The split method can't give me the option to register the starting and ending range positions of each word, because I may want to highlight them later on; plus when I add words to the dictionary, I eliminate the duplicate ones
Is there a way to dump the Range.Words collection without looping? I tried but it didn't work.
"when I add words to the dictionary, I eliminate the duplicate ones" - you don't have to do that: use an array of ranges as the value for the dictionary, with the word as the key.
For example:
Sub MapWords()
Dim d As New Scripting.Dictionary
Dim wrd As Variant, tmp, ub As Long, txt As String, w
Dim i As Long
For Each wrd In ActiveDocument.Range.Words
txt = Trim(wrd.Text)
If Len(txt) > 1 Then
If Not d.Exists(txt) Then
d.Add txt, GetArray(wrd)
Else
tmp = d(txt)
ub = UBound(tmp) + 1
ReDim Preserve tmp(1 To ub)
Set tmp(ub) = wrd
d(txt) = tmp
End If
End If
Next
'e.g. -
Set w = d("split")(1)
Debug.Print w.Text, w.Start, w.End
End Sub
Function GetArray(wrd)
Dim rv(1 To 1)
Set rv(1) = wrd
GetArray = rv
End Function
The Aim: using VBA (excel) to populate the clipboard with a table (from a listbox) in an excel friendly format so that I can then paste (ctrl+V) into excel and the values are split into the correct columns and rows as they were in the original listbox.
The Problem: I can't seem to get the formatting right; when I paste the contents of my clipboard into excel each row is contained in one cell (the first column) separated with "," (which is what I have tried to use as a sort of "delimiter" - not sure if this is correct or not?)
I am using the API workaround method to populate the clipboard and I don't want to wall you to death with code but here is the most important bit (I feel anyway - ask me if you need to see more code).
Private Sub btnCopyTable_Click()
Dim I As Long
Dim J As Long
Dim tmp As String
Dim arrItems() As String
Dim clipboard As DataObject
ReDim arrItems(0 To lbIPActions.ColumnCount - 1)
For J = 0 To lbIPActions.ListCount - 1
For I = 0 To lbIPActions.ColumnCount - 1
On Error Resume Next ' Handles null values
arrItems(I) = lbIPActions.Column(I, J)
On Error GoTo 0
Next I
tmp = tmp & Join(arrItems, ",") & vbCrLf
Next J
MsgBox tmp
ClipBoard_SetData tmp
End sub
The Current Output:
1,1,Low,Controls,,LS,Do this,02-Oct-2015,Note 1,Brev
2,1,Low,Controls,,LS,Do that,02-Oct-2015,Note 2,Brev
The Current State: I have had a little look around and found a way to do it in code to a specific sheet, but my end user requires the freedom to copy it into numerous sheets in a very ad hoc fashion. I know there is always the option to right click -> import text wizard, but again ctrl+V is the preferred method if possible.
As always, any help/advice is appreciated, thanks in advance.
Separate your string with Tab in each line and it'll work. Like so:
Dim I As Long
Dim J As Long
Dim textItem As String
Dim copyText As String
Dim clipboard As DataObject
For J = 0 To lbIPActions.ListCount - 1
For I = 0 To lbIPActions.ColumnCount - 1
textItem = vbNullString
On Error Resume Next ' Handles null values
textItem = lbIPActions.Column(I, J)
On Error GoTo 0
If I > 0 Then copyText = copyText & vbTab
copyText = copyText & textItem
Next I
If J < lbIPActions.ListCount - 1 Then copyText = copyText & vbNewLine
Next J
ClipBoard_SetData clipboardText
Using Microsoft Excel 2010, this macro searches for a list of phrases within a folder of text reports. For each phrase, it searches all of the reports and lists each report that contains the phrase.
I found some better macros to do each part of the macro - such as enumerating a directory, or finding a phrase within a text file - although I had a really hard time putting them together successfully. Despite it not being perfect, it may be helpful for others with the same problem, and I hope for some feedback on how to improve and optimize the macro.
Basic overview:
Column A: list of full path to text reports (for instance, "C:\path\to\report.txt")
Column B: name of report (such as "report.txt")
Column C: list of phrases to search for
Columns D+: output showing each report that contains the phrase (column C)
Areas for improvement:
Make the macro run faster! (This took over an hour for 360 reports and 1100 phrases)
Select the reports and report folder from a pop-up or other function (currently entered into the spreadsheet using another macro)
Filter reports by file name (for instance, only check reports with a word or phrase in the file name)
Filter reports by file extension (for instance, only check .txt files and not .xlsx files)
Detect the number of reports and phrases (currently this is hard coded)
Other suggestions / areas for improvement
Code:
Sub findStringMacro()
Dim fn As String
Dim lineString As String
Dim fileName As String
Dim searchTerm As String
Dim findCount As Integer
Dim i As Integer
Dim j As Integer
For i = 2 To 1109
searchTerm = Range("C" & i).Value
findCount = 0
For j = 2 To 367
fn = Range("A" & j).Value
fileName = Range("B" & j).Value
With CreateObject("Scripting.FileSystemObject").OpenTextFile(fn)
Do While Not .AtEndOfStream
lineString = .ReadLine
If InStr(1, lineString, searchTerm, vbTextCompare) Then
findCount = findCount + 1
Cells(i, 3 + findCount) = fileName
GoTo EarlyExit
End If
Loop
EarlyExit:
.Close
End With
Next j
Next i
End Sub
As #Makah pointed out, you're opening a lot of files, which is slow. To fix this, change the order of the loops (see the code below). This will switch from 407,003 file opens to 367. Along the same lines, lets create the FileSystemObject once, instead of once per file open.
Also, VBA is surprisingly slow at reading/writing data from/to Excel. We can deal with this by loading largw blocks of data into VBA all at once with code like
dim data as Variant
data = Range("A1:Z16000").value
And then writing it back to Excel in a large block like
Range("A1:Z16000").value = data
I have also added in code to dynamically check the dimension of your data. We assume that the data starts in cell A2, and if A3 is empty, we use the single cell A2. Otherwise, we use .End(xlDown) to move down to just above the first empty cell in column A. This is the equivalent of pressing ctrl+shift+down.
Note: the following code has not been tested. Also, it requires a reference to "Microsoft Scripting Runtime" for the FileSystemObjects.
Sub findStringMacro()
Dim fn As String
Dim lineString As String
Dim fileName As String
Dim searchTerm As String
Dim i As Integer, j As Integer
Dim FSO As Scripting.FileSystemObject
Dim txtStr As Scripting.TextStream
Dim file_rng As Range, file_cell As Range
Dim output As Variant
Dim output_index() As Integer
Set FSO = New Scripting.FileSystemObject
Set file_rng = Range("A2")
If IsEmpty(file_rng) Then Exit Sub
If Not IsEmpty(file_rng.Offset(1, 0)) Then
Set file_rng = Range(file_rng, file_rng.End(xlDown))
End If
If IsEmpty(Range("C2")) Then Exit Sub
If IsEmpty(Range("C3")) Then
output = Range("C2")
Else
output = Range(Range("C2"), Range("C2").End(xlDown))
End If
ReDim Preserve output(1 To UBound(output, 1), 1 To file_rng.Rows.Count + 1)
ReDim output_index(1 To UBound(output, 1))
For i = 1 To UBound(output, 1)
output_index(i) = 2
Next i
For Each file_cell In file_rng
fn = file_cell.Value 'Range("A" & j)
fileName = file_cell.Offset(0, 1).Value 'Range("B" & j)
Set txtStr = FSO.OpenTextFile(fn)
Do While Not txtStr.AtEndOfStream
lineString = txtStr.ReadLine
For i = 1 To UBound(output, 1)
searchTerm = output(i, 1) 'Range("C" & i)
If InStr(1, lineString, searchTerm, vbTextCompare) Then
If output(i, output_index(i)) <> fileName Then
output_index(i) = output_index(i) + 1
output(i, output_index(i)) = fileName
End If
End If
Next i
Loop
txtStr.Close
Next file_cell
Range("C2").Resize(UBound(output, 1), UBound(output, 2)).Value = output
Set txtStr = Nothing
Set FSO = Nothing
Set file_cell = Nothing
Set file_rng = Nothing
End Sub
i would like to extract data from text file into excel worksheet.
my text file format is not the same for each line.
so for each line read, the first data would go input into the 1st excel column, and the next data to go into the 2nd excel column(same row) which is 2 or more blank spaces away from the 1st data. This goes on until all the text file data in that line are input into different columns of the same row.
text file:
data1 (space) data2 (space,space,space) data3 (space,space) data4
excel:
column 1 | column 2 | column 3
data1 data2 | data3 | data4
i do not know how to identify the spaces in each line to be written to excel sheet, pls advise, below is my code:
Sub test()
Dim ReadData, myFile As String
myFile = Application.GetOpenFilename()
Open myFile For Input As #1
Do Until EOF(1)
Line Input #1, ReadData
Loop
End Sub
While David's Solution works fine, here is another way to go about it.
Like David's my solution assumes that each data piece is not broken. This solution also assumes that each new row (that has data) will be placed in the Sheet1 row after the prior row
You need to use the Split() function to separate the pieces of data into their respective Strings.
Then, only using the strings with actual characters (i.e. no spaces or blank lines), you Trim the strings to remove spaces before or after your data(s)
Once all this has occurred, you are left with desired elements in an array which you populate the columns with.
Sub test()
'variables
Dim ReadData, myFile As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim s As Variant
Dim stringTemp1() As String
Dim stringTemp2() As Variant
i = 1
'get fileName
myFile = Application.GetOpenFilename()
Open myFile For Input As #1
Do Until EOF(1)
Line Input #1, ReadData
'check to make sure line is not empty
If Not ReadData = "" Then
'split row into array of strings
stringTemp1 = Split(ReadData, " ")
'remove any string elements that are blank
j = 0
ReDim stringTemp2(j)
For Each s In stringTemp1
If Not IsSpace(s) Then
ReDim Preserve stringTemp2(j)
stringTemp2(j) = s
j = j + 1
End If
Next s
'remove excess spaces from each element when adding to cell
For k = 0 To UBound(stringTemp2)
Worksheets("Sheet1").Cells(i, k + 1).Value = Trim(stringTemp2(k))
Next k
i = i + 1
Erase stringTemp2
Erase stringTemp1
End If
Loop
Close #1
End Sub
This external function was to check if an element in stringTemp1 contained data or not
Function IsSpace(ByVal tempString As String) As Boolean
IsSpace = False
If tempString = "" Then
IsSpace = True
End If
End Function
Assuming that each element of "data" does not internally contain spaces (e.g., your data is non-breaking, such as "John" or 1234 but not like "John Smith", or "1234 Main Street") then this is what I would do.
Use the Split function to convert each line to an array. Then you can iterate the array in each column.
Sub test()
Dim ReadData As String
Dim myFile As String
Dim nextCol as Integer
myFile = Application.GetOpenFilename()
Open myFile For Input As #1
Do Until EOF(1)
nextcol = nextCol + 1
Line Input #1, ReadData
Call WriteLineToColumn(ReadData, nextCol)
Loop
End Sub
Now that will call a procedure like this which splits each line (ReadData) and puts it in to the column numbered nextCol:
Sub WriteLineToColumn(s As String, col as Integer)
'Converts the string of data to an array
'iterates the array and puts non-empty elements in to successive rows within Column(col)
Dim r as Long 'row counter
Dim dataElement as Variant
Dim i as Long
For i = lBound(Split(s, " ")) to UBound(Split(s, " "))
dataElement = Trim(Split(s)(i))
If Not dataelement = vbNullString Then
r = r + 1
Range(r, col).Value = dataElement
End If
Next
End Sub
NOTE ALSO that a declaration of Dim ReadData, myFile as String is declaring ReadData as type Variant. VBA does not support implied declarations like this. To properly, strongly type this variable, it needs to be: Dim ReadData as String, myFile as String.