I am trying to read every two lines of text, create a slide, and insert each line in the cells of a 2 by 1 table respectively using VBA code.
Public Sub newSlide()
Dim FileNum As Integer
Dim DataLine As String
Dim Count As Integer
Count = 0
FileNum = FreeFile()
Open "C:\Users\ADMININST\Documents\my.txt" For Input As #FileNum
While Not EOF(FileNum)
Count = Count + 1
Line Input #FileNum, DataLine ' read in data 1 line at a time
' decide what to do with dataline,
' depending on what processing you need to do for each case
Debug.Print ("Love you")
If Count Mod 2 = 1 Then
Dim pptSlide As Slide
Dim pptLayout As CustomLayout
Set pptLayout = ActivePresentation.Slides(1).CustomLayout
Set pptSlide = ActivePresentation.Slides.AddSlide(2, pptLayout)
'ActivePresentation.Slides.Add Index:=ActivePresentation.Slides.Count + 1, Layout:=ppLayoutCustom
Dim pptTable As Table
pptTable = pptSlide.Shapes.AddTable(2, 1).Select
pptTable.Cell(1, Count Mod 2) = DataLine
End If
Wend
End Sub
I get a compile error;
"expected Function or variable" for the line below. It seems Select is not returning the table.
pptTable = pptSlide.Shapes.AddTable(2, 1).Select
Here's a rework of your code:
Dim pptTable As Shape
Set pptTable = pptSlide.Shapes.AddTable(2, 1)
pptTable.Table.Cell(1, Count Mod 2).Shape.TextFrame.TextRange.Text = DataLine
The object produced by Shapes.AddTable is a Shape, which contains a table. So I changed the Dim statement to make that work.
The Select is unneccessary. Using Set makes pptTable a shape that you can refer to.
When your code gets past that error, it runs into another in the next line. You need to refer to the Text inside the TextRange, inside the TextFrame, inside the Shape, inside the cell to place the string.
Related
I am writing my first ms word macro which iterates through all rows of the table and deletes the selected one. Here is the code
Sub TableCleaner()
'
' TableCleaner Macro
'
'
Dim objTable As Table
Dim sourceDocument As Document
Set sourceDocument = ActiveDocument
Dim UserChoice As String
Dim QuestionToMessageBox As String
QuestionToMessageBox = "Delete row with Text?"
Dim targetRows() As Row
ReDim targetRows(1 To 1) As Row
For Each oRow In sourceDocument.Tables(1).Rows
UserChoice = MsgBox(oRow.Cells(1).Range.Text, vbYesNo, "Delete Row?")
If UserChoice = vbYes Then
targetRows(UBound(targetRows)) = oRow
ReDim Preserve targetRows(1 To UBound(targetRows) + 1) As Row
oRow.Shading.BackgroundPatternColor = Word.WdColor.wdColorLightGreen
End If
Next oRow
Confirmation = MsgBox("Are you sure?", vbYesNo, "Confirm?")
If Confirmation = vbYes Then
For Each targetRow In targetRows
targetRow.Delete
Next targetRow
End If
End Sub
I am following getting an error at line targetRows(UBound(targetRows)) = oRow
Compile error:
Invalid use of property
It's because a Row is an object, not a string, number or something "simple".
When you assign an object you need to use the keyword Set. (Happens to me all the time in similar situations!) So:
Set targetRows(UBound(targetRows)) = oRow
Note: You should use Option Explicit at the top of your code modules. That forces you to declare (use Dim) every variable you use and will help avoid spelling errors with variable names, etc.
You need to Set the target row:
Set targetRows(UBound(targetRows)) = oRow
In your code, on below line, it is expecting an index value like 1, 2, 3 for targetRows
targetRows(UBound(targetRows)) = oRow
#PKatona when I tried it in a real setting it overwrote some files. Upon examining the code, I realized it was counting the number of files in the directory and saving as the next number (say 15th file in folder as 'ST14 TC15') instead of saving as the highest next number in the filenames (say there are only 3 files in the directory and the one with the highest ending is 'ST14 TC06' so the next file should be saved as 'ST14 TC07'. I hope that makes sense. But using some of your code I was able to come up with this: however 1) there must be a way to shorten it! 2) it works in Excel (where I made it) but 'Evaluate' line towards the end gives 'Sub or function not defined' error in Word!!
Thanks again
`Sub Largest()
Dim rng As Range
Dim dblMax As Double
Dim var_data(200)
Dim var_numdata(200)
'* - * - *
'to put filenames in a specific directory into an array
Dim MyFile As String
Dim Counter As Long
'Create a dynamic array variable, and then declare its initial size
Dim DirectoryListArray() As String
ReDim DirectoryListArray(1000)
Dim str()
ReDim str(1000)
Dim num()
ReDim num(1000)
'Loop through all the files in the directory by using Dir$ function
MyFile = Dir$("C:\HAPPY\SANTA\ELVES\*.docx")
Do While MyFile <> ""
DirectoryListArray(Counter) = MyFile
MyFile = Dir$
str(Counter) = Mid(DirectoryListArray(Counter), 8, 3)
num(Counter) = Evaluate(str(Counter))
Counter = Counter + 1
Loop
'Reset the size of the array without losing its values
ReDim Preserve DirectoryListArray(Counter - 1)
ReDim Preserve str(Counter - 1)
ReDim Preserve num(Counter - 1)
dblMax = Application.WorksheetFunction.Max(num())
Dim nextFilename As String
nextFilename = "C:\HAPPY\SANTA\ELVES\ST14 HP" + Format((dblMax + 1), "000")+ ".docx"
ActiveDocument.SaveAs Filename:=nextFilename
ActiveDocument.Close
End Sub
This will find the last file sequence:
Dim filename as String
Dim seq as Integer
seq = 1
filename = Dir("C:\HAPPY\SANTA\ELVES\ST14 TC*.docx")
Do While filename <> ""
seq = seq + 1
filename = Dir
Loop
Dim nextFilename as String
nextFilename = "C:\HAPPY\SANTA\ELVES\ST14 TC" + Format(seq, "000") + ".docx"
Add your macro code here...
I am writing code which matches a date (from a file), puts this into a collection and then attempts to find this on a spreadsheet. Once it finds it, it puts the following two items in the collection in the two cells. When I run this I get the following error: "Object variable or With block variable not set". I have attempted to debug my code and it shows that after the first loop of the code below, the range object, "rthecell", changes to the proper value. Once the second iteration of the loop occurs the value of "rthecell" changes to "Nothing".
Ex:
Set rtheCell = Range("A:A").Find(What:=LineItem1)
rtheCell.Offset(, 1).Value = LineItem3
rtheCell.Offset(, 2).Value = LineItem2
Set rtheCell = Nothing
Again, everything works as intended on the first iteration of the loop but I receive the error once the second iteration occurs.
Here is the full code:
Sub InputData()
'Declare variables
Dim sFilePath As String
Dim sLineFromFile As String
Dim saLineItems() As String
Dim element As Variant
Dim col As Collection
Dim LineItem1 As String
Dim LineItem2 As String
Dim LineItem3 As String
Dim rtheCell As Range
Set col = New Collection
'Insert file path name here, this file will be overwritten each morning
sFilePath = "P:\Billing_Count.csv"
Open sFilePath For Input As #1
Do Until EOF(1)
Line Input #1, sLineFromFile
'Split each line into a string array
'First replace all space with comma, then replace all double comma with single comma
'Replace all commas with space
'Then perform split with all values separated by one space
sLineFromFile = Replace(sLineFromFile, Chr(32), ",")
sLineFromFile = Replace(sLineFromFile, ",,", ",")
sLineFromFile = Replace(sLineFromFile, ",", " ")
saLineItems = Split(sLineFromFile, " ")
'Add line from saLineItem array to a collection
For Each element In saLineItems
If element <> " " Then
col.Add element
End If
Next
Loop
Close #1
'Place each value of array into a smaller array of size 3
Dim i As Integer
i = 1
Do Until i > col.Count
'Place each value of array into a string-type variable
'This line is the date
LineItem1 = col.Item(i)
i = i + 1
'This line should be the BW count make sure to check
LineItem2 = col.Item(i)
i = i + 1
'This line should be the ECC count make sure to check
LineItem3 = col.Item(i)
i = i + 1
'Find the matching date in existing Daily Billing File (dates on Excel must be formatted as
'general or text) and add ECC and BW counts on adjacent fields
Set rtheCell = Range("A3:A37").Find(What:=LineItem1)
rtheCell.Offset(, 1).Value = LineItem3 'This is LineItem3 since we can ECC data to appear before BW
rtheCell.Offset(, 2).Value = LineItem2
Set rtheCell = Nothing
LineItem1 = 0
Loop
'Format cells to appear as number with no decimals
'Format cells to have horizontal alignment
Sheets(1).Range("B3:C50").NumberFormat = "0"
Sheets(1).Range("C3:C50").HorizontalAlignment = xlRight
End Sub
when you use the Range.Find method, typically you would either use the After:= parameter in subsequent calls or use the Range.FindNext method which assumes After:= the last found item. Since you are not modifying the actual found cells' value(s) in any way, you need to record the original found cell (typically the address) because eventually you will loop back to the original.
dim fndrng as range, fndstr as string
set fndrng = Range("A:A").Find(What:=LineItem1, after:=cells(rows.count, "A"))
if not fndrng is nothing then
fndstr = fndrng.address
do while True
'do stuff here
set fndrng = Range("A:A").FindNext(after:=fndrng)
if fndstr = fndrng.address then exit do
loop
end if
That should give you the idea of looping through all the matching calls until you loop back to the original. tbh, it is hard to adequately expand on the small amount of code supplied.
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.