Read Each line not reading through entire file - vb.net
I am using Vb to take a .txt file, parse it, and check for errors. My code works just fine, however, the code does not go through the entire file. It stops, on average, 20 lines shy of the EOF.
I am using the following
For Each lines As String In System.IO.File.ReadLines(myFile)
from here I parse the line and see if it needs any fixes.
Is there something that I'm missing or something that just cant be avoided.
The files that I'm reading in are about 150,000 KB to 230,000 KB and over 2 million lines.
As requested, the following is my code. Warning, I just started using Vb...
Module Module1
Sub Main()
Dim root As String = "C:\Users\mschramm\Documents\Agco\WindSensor\Data\filestobecleaned\"
Dim datafile As String = root & "ES.txt"
Dim outfile As String = root & "temptry.txt"
Dim output As System.IO.StreamWriter = My.Computer.FileSystem.OpenTextFileWriter(outfile, False)
Dim k As UInteger = 0
Dim fixes As UInteger = 0
Dim time As ULong = 0
Dim count As UInteger = 0
Dim n As UInteger = 0
Dim LineCount As UInteger = 0
Dim TimeStep As ULong = 100
Dim Solar As UInteger = 0
For Each lines As String In System.IO.File.ReadLines(datafile)
LineCount = LineCount + 1
'Console.WriteLine(LineCount)
Dim parsedline As String() = Split(lines, ",")
If IsNumeric(parsedline(0)) = True And UBound(parsedline) = 8 Then
'TimeStep = parsedline(0) - time
Solar = parsedline(1)
time = parsedline(0)
output.WriteLine(lines & " Good Line")
count = count + 1
Else
Dim j As UInteger = 0
Dim ETX As Integer = 0
Dim STX As Integer = 0
Dim datacheck As Boolean = False
Dim fixedline As String = ""
Dim newtime As ULong = 0
For j = 0 To UBound(parsedline)
Dim a As Char = parsedline(j)
If a = (Chr(3)) Then ETX = j
If a = (Chr(2)) Then STX = j
Next
j = 0
If (STX < ETX) And (ETX - STX) = 6 And STX >= 2 Then
If Len(parsedline(STX + 1)) = 8 And Len(parsedline(STX + 2)) = 8 And Len(parsedline(STX + 3)) = 8 Then
Dim g = Len(parsedline(STX - 2))
While (j < g) And datacheck = False
If IsNumeric(parsedline(STX - 2)) Then
If parsedline(STX - 2) - time < 10000 And parsedline(STX - 2) - time > 0 Then
newtime = Right(parsedline(STX - 2), Len(parsedline(STX - 2)))
Solar = parsedline(STX - 1)
'TimeStep = newtime - time
fixedline = newtime & "," & parsedline(STX - 1) & "," & parsedline(STX) & "," & parsedline(STX + 1) & "," & parsedline(STX + 2) & "," & parsedline(STX + 3) & "," & parsedline(STX + 4) & "," & parsedline(STX + 5) & "," & parsedline(STX + 6) & " Fixed Line"
datacheck = True
Else
j = j + 1
parsedline(STX - 2) = Right(parsedline(STX - 2), Len(parsedline(STX - 2)) - 1).ToString
End If
Else
j = j + 1
parsedline(STX - 2) = Right(parsedline(STX - 2), Len(parsedline(STX - 2)) - 1).ToString
End If
End While
End If
End If
If (STX < ETX) And (ETX - STX) = 6 And STX = 0 Then
If Len(parsedline(1)) = 8 And Len(parsedline(2)) = 8 And Len(parsedline(3)) = 8 And Len(parsedline(4)) = 1 And Len(parsedline(5)) = 2 And Len(parsedline(6)) = 3 Then
newtime = time + TimeStep
fixedline = newtime & "," & Solar & "," & parsedline(STX) & "," & parsedline(STX + 1) & "," & parsedline(STX + 2) & "," & parsedline(STX + 3) & "," & parsedline(STX + 4) & "," & parsedline(STX + 5) & "," & parsedline(STX + 6) & " Fixed Line Gave Time and Solar"
datacheck = True
End If
End If
If newtime < time And newtime > 1000 Then
Dim badtime As ULong = newtime
Dim firstdig As ULong = time
Dim loopcount As UInteger = 0
While firstdig > 9
firstdig = firstdig / 10
loopcount = loopcount + 1
End While
firstdig = firstdig * (10 ^ loopcount)
If (firstdig + badtime) > time Then
newtime = firstdig + badtime
If (newtime - (10 ^ loopcount)) > time Then
newtime = newtime - (10 ^ loopcount)
End If
End If
End If
If datacheck = True Then
k = k + 1
If (newtime > 500) Then
output.WriteLine(fixedline)
'count = count + 1
time = newtime
End If
End If
If datacheck = False Then
n = n + 1
If STX >= 0 And ETX > 0 And ETX - STX < 9 Then
Console.WriteLine(LineCount)
'n = n + 1
End If
End If
End If
Next
Console.WriteLine(count & " Good lines")
Console.WriteLine(k & " Lines Corrected")
Console.WriteLine(LineCount & " Total Lines")
Console.WriteLine(n & " Lines were thrown out")
Console.WriteLine(n / LineCount * 100 & "% thrown out")
End Sub
End Module
and here is a sample of the data
Time: 16:52:18.0
Date: 11/6/2014
Time,Sensor1,U,V,W
544161,219,Q,-001.341,+000.947,+000.140,M,00,17
544284,218,Q,-001.207,+001.074,+000.225,M,00,1C
544361,220,Q,-000.935,+000.898,+000.187,M,00,17
544460,220,Q,-001.299,+001.151,-000.009,M,00,17
This is what the last 10 lines look like
Q,+001.681,-003.510,-0356154697,236,Q,+000.826,-002.744,-000.559,M,00,19
Q,+000.474,-002.789,-0356155062,234,Q,+000.400,-002.975,+000.438,M,00,1D
Q,+000.813,-002.934,-0356155297,236,Q,+000.146,-002.129,-000.235,M,00,16
Q,+000.494,-002.234,+0356155497,236,Q,+000.681,-001.996,-000.248,M,00,1F
Q,+000.800,-001.999,-0356155697,236,Q,+001.181,-002.883,-000.795,M,00,1A
356156060,233,Q,+000.400,-002.106,+000.251,M,00,18
356156296,235,Q,+000.888,-001.026,+000.442,M,00,10
356156495,236,Q,+000.570,-001.694,+000.589,M,00,13
356156695,236,Q,+001.495,-002.177,-000.035,M,00,15
356157060,234,Q,+000.770,-003.484,-000.161,M,00,14
for this file, the code makes it to the 6th to last line.
Thanks to mafafu for pointing out the solution.
I never closed the file, so the addition of output.Close() fixed everything.
Once again, thank you mafafu.
Related
Type Mismatch in Dlookup
I'm getting a type mismatch in the Dlookup below. Note: the ID column in the Results2 Table is formatted as a Number. If DLookup("[Result" & i & "]", "Results2", "[ID] = '" & newid & "'") <> Me.Controls("C" & 3 + column & "R" & i + j).Value Then I've tried changing the newid from a string to an Integer or a Long, but I still get this error. Full code for this Sub below, if more info is needed. Private Sub BtnSave_Click() Dim db As DAO.Database Dim rs As DAO.Recordset Dim rs2 As DAO.Recordset Dim rs3 As DAO.Recordset Dim i As Integer Dim j As Integer Dim ans As Integer Dim column As Integer Dim colcnt As Integer Dim newid As String If IsNull(Me.Spindle3.Value) = False Then colcnt = 3 ElseIf IsNull(Me.Spindle2.Value) = False Then colcnt = 2 Else colcnt = 1 End If column = 1 Set db = CurrentDb Set rs = db.OpenRecordset("Results") Set rs2 = db.OpenRecordset("Results2") Set rs3 = db.OpenRecordset("Results3") Linestart: j = 0 rs.AddNew newid = rs![ID].Value If Me.Result1.Value = "Fail" Or Me.Result2.Value = "Fail" Or Me.Result1.Value = "Fail" Then If column = 1 Then ans = MsgBox("This is a FAILING Result. Do you with to save it?", vbYesNo) If ans = 7 Then GoTo Lineend End If ElseIf Me.Result1.Value = "Incomplete" Or Me.Result2.Value = "Incomplete" Or Me.Result2.Value = "Incomplete" Then If column = 1 Then ans = MsgBox("Testing is not finished for this part. Do you with to save and close now?", vbYesNo) If ans = 7 Then GoTo Lineend End If End If With rs ![PartNum] = Me.FilterPartNumber.Value ![INDNum] = Me.INDNum.Value ![DateTime] = Me.DateTime.Value ![HTLotNum] = Me.HTLotNum.Value ![Operator] = Me.Inspector.Value ![Spindle] = Me.Controls("Spindle" & column).Value ![TypeofCheck] = Me.InspType.Value ![OverallResult] = Me.Controls("Result" & column).Value End With rs2.AddNew With rs2 ![ID] = newid ![PartNum] = Me.FilterPartNumber.Value ![Plant] = Me.plantnum.Value ![DateTime] = Me.DateTime.Value ![HTLotNum] = Me.HTLotNum.Value ![Notes] = Me.Notes.Value ![Spindle] = Me.Spindle.Value ![TypeofCheck] = Me.InspType.Value ![OverallResult] = Me.Result1.Value End With rs3.AddNew With rs3 ![ID] = newid ![PartNum] = Me.FilterPartNumber.Value ![DateTime] = Me.DateTime.Value End With If IsNull(Me.HTLotNum.Value) = True Then rs![HTLotNum] = "(blank)" rs![HTLotNum] = "(blank)" End If For i = 1 To 90 Step 1 If i + j >= 90 Then i = 90 GoTo Line1 End If If IsNull(Me.Controls("C3R" & i + j).Value) = True Then j = j + 1 End If If i + j >= 90 Then i = 90 GoTo Line1 End If If IsNull(Me.Controls("C2R" & i + j).Value) = True Then GoTo Line1 rs("Char" & i) = Me!ListFeatures.column(1, i - 1) rs("Desc" & i) = Me!ListFeatures.column(2, i - 1) rs("Spec" & i) = Me!ListFeatures.column(3, i - 1) & " " & Me!ListFeatures.column(6, i - 1) rs2("SC" & i) = Me!ListFeatures.column(4, i - 1) rs2("Location" & i) = Me!ListFeatures.column(5, i - 1) rs2("Result" & i) = Me.Controls("C" & 3 + column & "R" & i + j).Value rs3("Coding" & i) = Me!ListCoding.column(1, i - 1) Line1: Next rs.Update rs2.Update rs3.Update For i = 1 To 90 Step 1 If i + j >= 90 Then i = 90 GoTo Line1 End If If IsNull(Me.Controls("C3R" & i + j).Value) = True Then j = j + 1 End If If i + j >= 90 Then i = 90 GoTo Line1 End If If DLookup("[Result" & i & "]", "Results2", "[ID] = '" & newid & "'") <> Me.Controls("C" & 3 + column & "R" & i + j).Value Then MsgBox "Results not saved! Document results on paper and contact the database engineer regarding this error." GoTo Lineend: End If Next If column < colcnt Then column = column + 1 GoTo Linestart End If Line2: Forms![Landing Page]![LIstIncomplete].Requery DoCmd.Close Lineend: End Sub
Per one of the comments, I updated the trouble line to the line below. I'm almost certain that was how I initially wrote this line and added the apostrophes as an attempt to fix. If DLookup("[Result" & i & "]", "Results2", "[ID] = " & newid) <> Me.Controls("C" & 3 + column & "R" & i + j).Value Then I had to fix one of my Goto's as well, one of them led to an infinite loop, but now everything is working as intended. Thanks for the help!
Error 1004 Macro Excel
I'm currently having some issues with VBA and the error 1004. I checked on the Internet but, unfortunately, couldn't find the solution. I'm working on data transfer between Excel and an other base. I'm currently on the first part of the work : the shape of the new document before the transfer. In fact, I can have text with more than 250 characters on my first database while the other one wants me to split all of the documents each 250 characters (as you can check on the program) and add a number associated to help to gather the information. It works very well until I reach the line Sheets("LibImport").Range("F" & ligneLib) = Mid(Sheets("NCXL").Range("B" & ligneNC), 250 * (j - 1) + 1, 250) with j = 2, LigneLib = 3899 and a text with 257 characters. This code already worked for texts with more than 500 characters that is why I don't understand the issue. Moreover, When I delete all of the lines to start the macro again, I still have the error on the same line on the first loop. However, it works again only when I restart Excel. Please find below the details of the macro : Option Explicit Sub Libelle() Dim ligneLib As Integer Dim ligneNC As Integer Dim endLoop As Integer Dim i As Integer Dim j As Integer ligneNC = 3 ligneLib = 1 For i = 1 To 3003 endLoop = Round_Up(Len(Sheets("NCXL").Range("B" & ligneNC)) / 250) For j = 1 To endLoop 'Texte description Sheets("LibImport").Range("A" & ligneLib) = "100" Sheets("LibImport").Range("B" & ligneLib) = Sheets("NCXL").Range("A" & ligneNC) & "-DESC" Sheets("LibImport").Range("C" & ligneLib) = "NONCONFO" Sheets("LibImport").Range("D" & ligneLib) = j Sheets("LibImport").Range("F" & ligneLib) = Mid(Sheets("NCXL").Range("B" & ligneNC), 250 * (j - 1) + 1, 250) ligneLib = ligneLib + 1 Next endLoop = Round_Up(Len(Sheets("NCXL").Range("C" & ligneNC)) / 250) For j = 1 To endLoop 'Texte cause Sheets("LibImport").Range("A" & ligneLib) = "100" Sheets("LibImport").Range("B" & ligneLib) = Sheets("NCXL").Range("A" & ligneNC) & "-CAUSE" Sheets("LibImport").Range("C" & ligneLib) = "NONCONFO" Sheets("LibImport").Range("D" & ligneLib) = j Sheets("LibImport").Range("F" & ligneLib) = Mid(Sheets("NCXL").Range("C" & ligneNC), 250 * (j - 1) + 1, 250) ligneLib = ligneLib + 1 Next endLoop = Round_Up(Len(Sheets("NCXL").Range("E" & ligneNC)) / 250) For j = 1 To endLoop 'Texte action corrective Sheets("LibImport").Range("A" & ligneLib) = "100" Sheets("LibImport").Range("B" & ligneLib) = Sheets("NCXL").Range("A" & ligneNC) & "-DSCCOR" Sheets("LibImport").Range("C" & ligneLib) = "NONCONFO" Sheets("LibImport").Range("D" & ligneLib) = j Sheets("LibImport").Range("F" & ligneLib) = Mid(Sheets("NCXL").Range("E" & ligneNC), 250 * (j - 1) + 1, 250) ligneLib = ligneLib + 1 Next endLoop = Round_Up(Len(Sheets("NCXL").Range("D" & ligneNC)) / 250) For j = 1 To endLoop 'Texte action curative Sheets("LibImport").Range("A" & ligneLib) = "100" Sheets("LibImport").Range("B" & ligneLib) = Sheets("NCXL").Range("A" & ligneNC) & "-DECIS" Sheets("LibImport").Range("C" & ligneLib) = "NONCONFO" Sheets("LibImport").Range("D" & ligneLib) = j Sheets("LibImport").Range("F" & ligneLib) = Mid(Sheets("NCXL").Range("D" & ligneNC), 250 * (j - 1) + 1, 250) ligneLib = ligneLib + 1 Next ligneNC = ligneNC + 1 Next End Sub Function Round_Up(ByVal val As Double) As Integer Dim result As Integer result = Round(val) If result >= val Then Round_Up = result Else Round_Up = result + 1 End If End Function Thanks, Cédric.
The 251st character of your example text is an = symbol. When you write that to a cell, Excel assumes you're entering a formula. To work around this issue, precede the text with a ' as you would if you were keying it manually: Sheets("LibImport").Range("F" & ligneLib) = "'" & Mid(Sheets("NCXL").Range("B" & ligneNC), 250 * (j - 1) + 1, 250) They won't be visible in Excel, but you might need to account for them if you're doing other things later with the contents of that cell.
Identify Paragraph content with certain outline level
I have a macro which pass through paragraphs of a word document. This code is intended to pass the paragraph, identify its outline level and retrieve the content when the desired paragraph outline level is found. With this information, I'm populating a listbox that will allow users to choose from what point they want to export some text in a document. This functionality is working, however, I'm looking for a way to improve its speed. Right now I'm handling a document with 5678 paragraphs, and it is taking over 30 minutes to process all the information. Do you have any suggestion? I had tried to approaches without having success: 1 - I've tried to use the object TableOfContents, however I was not able to have a clean information and differentiate outline levels from the paragraphs. 2 - I've tried to adapt the code from here Getting the headings from a Word document, specially because of the use of the command _docSource.GetCrossReferenceItems(wdRefTypeHeading), also with no success Here there is the image of the form, and the code I'm using. Sub ProcessHeaders() Dim j As Long Dim Paragraph_Number() As Variant Dim Paragraph_Content() As Variant Dim Paragraph_Mapping() As Variant j = 1 With UserForm1 If .ComboBox4.ListCount > 0 Then .ComboBox4.Clear End If For i = 1 To wordDoc.Paragraphs.Count If wordDoc.Paragraphs.Item(i).OutlineLevel = wdOutlineLevel1 _ Or wordDoc.Paragraphs.Item(i).OutlineLevel = wdOutlineLevel2 _ Or wordDoc.Paragraphs.Item(i).OutlineLevel = wdOutlineLevel3 _ Or wordDoc.Paragraphs.Item(i).OutlineLevel = wdOutlineLevel4 Then If wordDoc.Paragraphs.Item(i).Range.ListFormat.ListString <> "" Then ReDim Preserve Paragraph_Number(j) ReDim Preserve Paragraph_Content(j) Paragraph_Content(j) = wordDoc.Paragraphs.Item(i).Range.ListFormat.ListString & " " & Trim(Left(wordDoc.Paragraphs.Item(i).Range.Text, (Len(wordDoc.Paragraphs.Item(i).Range.Text) - 1))) Paragraph_Number(j) = i j = j + 1 End If End If Next i ReDim Preserve Paragraph_Mapping(1 To UBound(Paragraph_Content), 1) For i = 1 To UBound(Paragraph_Number) Paragraph_Mapping(i, 0) = Paragraph_Content(i) Paragraph_Mapping(i, 1) = Paragraph_Number(i) Next i .ComboBox4.List = Paragraph_Mapping End With End Sub Edit 1 - I Achieve to reduce the time from 32 minutes to 8 minutes of execution with the code below. Any suggestions to improve even more? Thanks in advance Sub ProcessHeaders() Dim j As Long Dim thisOutlineLevel As WdOutlineLevel Dim thisHeader As String Dim thisList As String Dim ParagraphCount As Long Dim Paragraph_Number_Base() As Variant Dim Paragraph_Content_Base() As Variant Dim Paragraph_ListItem_Base() As Variant Dim ParagraphContent() As Variant Dim ParagraphNumber() As Variant Dim Paragraph_Mapping() As Variant Dim StartTime As Double Dim MinutesElapsed As String j = 1 With UserForm1 If .ComboBox4.ListCount > 0 Then .ComboBox4.Clear End If ParagraphCount = wordDoc.Paragraphs.Count ReDim Paragraph_Content_Base(ParagraphCount + 1) ReDim Paragraph_ListItem_Base(ParagraphCount + 1) ReDim Paragraph_Number_Base(ParagraphCount + 1) StartTime = Timer For i = 1 To ParagraphCount MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss") UserForm1.Label7.Caption = "Reading Paragraphs. " & Format(i / ParagraphCount, "0%") & " | Total of Paragraphs Found: " & ParagraphCount & " | Time Elapsed: " _ & MinutesElapsed & " Minutes" With wordDoc.Paragraphs.Item(i) Select Case .OutlineLevel Case wdOutlineLevelBodyText GoTo ResumeNext Case wdOutlineLevel1, wdOutlineLevel2, wdOutlineLevel3, wdOutlineLevel4 Paragraph_Content_Base(i) = .Range.Text Paragraph_ListItem_Base(i) = .Range.ListFormat.ListString Paragraph_Number_Base(i) = i End Select End With ResumeNext: Next i MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss") UserForm1.Label7.Caption = ParagraphCount & " read on " & MinutesElapsed & " Minutes. Now, identifying the Headers" For i = 0 To UBound(Paragraph_Content_Base) If Paragraph_Content_Base(i) <> "" And Paragraph_ListItem_Base(i) <> "" Then ReDim Preserve ParagraphContent(j) ReDim Preserve ParagraphNumber(j) ParagraphContent(j) = Trim(Paragraph_ListItem_Base(i)) & " " & Trim(Left(Paragraph_Content_Base(i), Len(Paragraph_Content_Base(i)) - 1)) ParagraphNumber(j) = Paragraph_Number_Base(i) j = j + 1 End If Next i Erase Paragraph_Content_Base Erase Paragraph_ListItem_Base Erase Paragraph_Number_Base ReDim Preserve Paragraph_Mapping(1 To UBound(ParagraphContent), 1) For i = 1 To UBound(ParagraphNumber) Paragraph_Mapping(i, 0) = ParagraphContent(i) Paragraph_Mapping(i, 1) = ParagraphNumber(i) Next i .ComboBox4.List = Paragraph_Mapping MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss") UserForm1.Label7.Caption = "Identifying Headers: " & j & " identified. Total Time: " & MinutesElapsed & " minutes" End With Edit 2 - With the Help of Cindy, the code which was initially running in 32 minutes right now is running on 32 seconds. Here is the final Code. Sub ProcessHeaders() Dim rng As Word.Range Dim para As Word.Paragraph Dim lstFormat As Word.ListFormat Dim paraNr() As Variant Dim paraContent() As Variant Dim counter As Long, paraIndex As Long Dim Paragraph_Mapping() As Variant Dim ParagraphCount As Long Dim i, j As Long Dim StartTime As Double Dim StartRealTime As Date Dim MinutesElapsed As String With UserForm1 If .ComboBox4.ListCount > 0 Then .ComboBox4.Clear End If counter = 1 paraIndex = 1 i = 0 j = 1 StartTime = Timer StartRealTime = Now Set rng = wordDoc.Content ParagraphCount = rng.ListParagraphs.Count For Each para In rng.ListParagraphs i = i + 1 Set lstFormat = para.Range.ListFormat MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss") .Label7.Caption = "Reading Paragraphs. " & Format(i / ParagraphCount, "0%") & " | Total of Paragraphs Found: " & ParagraphCount & _ " | Start Time: " & StartRealTime & " | Time Elapsed: " & MinutesElapsed & " Minutes" 'CheckOutLine = rng.ListParagraphs.Item(1).OutlineLevel If lstFormat.ListString <> "" And Len(lstFormat.ListString) >= 2 Then ReDim Preserve paraNr(counter) ReDim Preserve paraContent(counter) paraContent(counter) = lstFormat.ListString & " " _ & Trim(Left(para.Range.Text, (Len(para.Range.Text) - 1))) paraNr(counter) = i wordDoc.Bookmarks.Add Name:="ExpContent" & i, Range:=para.Range counter = counter + 1 End If paraIndex = paraIndex + 1 Next j = 1 ReDim Preserve Paragraph_Mapping(1 To UBound(paraNr), 1) For i = UBound(paraNr) To 1 Step -1 Paragraph_Mapping(j, 0) = paraContent(i) Paragraph_Mapping(j, 1) = paraNr(i) j = j + 1 Next i .ComboBox4.List = Paragraph_Mapping MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss") .Label7.Caption = "Identifying Headers: " & j & " identified. Total Time: " & MinutesElapsed & " minutes" End With ' ' For counter = 1 To UBound(paraNr) ' Debug.Print paraNr(counter) & vbTab & paraContent(counter) ' Next End Sub And After the user choose the paragraph, the bookmarks are being managed by this call With objWord.Selection BookmarkID = "ExpContent" & PositionReference wordDoc.Bookmarks(BookmarkID).Select .InsertParagraphBefore End With Once again, thank you
I think the fastest approach is going to be looping only the numbered paragraphs, rather than all paragraphs. This can be done using the ListParagraphs object. For example: Sub IdOutlineLevels() Dim rng As word.Range Dim para As word.Paragraph Dim lstFormat As word.ListFormat Dim paraNr() As Variant Dim paraContent() As Variant Dim counter As Long, paraIndex As Long counter = 1 paraIndex = 1 Set rng = ActiveDocument.content For Each para In rng.ListParagraphs Set lstFormat = para.Range.ListFormat Select Case lstFormat.ListLevelNumber Case 1, 2, 3, 4 If lstFormat.ListString <> "" Then ReDim Preserve paraNr(counter) ReDim Preserve paraContent(counter) paraContent(counter) = lstFormat.ListString & " " _ & Trim(Left(para.Range.Text, (Len(para.Range.Text) - 1))) paraNr(counter) = paraIndex counter = counter + 1 ActiveDocument.Bookmarks.Add Name:="ExpContent" & counter, Range:=para.Range End If Case Else End Select paraIndex = paraIndex + 1 Next For counter = 1 To UBound(paraNr) Debug.Print paraNr(counter) & vbTab & paraContent(counter) Next End Sub Rather than relying on the index number of the paragraph in the document to locate the paragraph again I've added bookmarks to each of the paragraphs using the same "counter" as the paragraph number. This is the technique Word, itself, uses for cross-referencing.
Run-time error '1004': Application-defined or object-defined error with repeated use of "range" object
I'm trying to make an automated templated with VBA and this code seems to run fine when I enter in a low number of "pages", but when I enter in something such as the following into the prompts it gives me a run-time error 1004: 14 pages: 41, 26, 19, 28, 26, 28, 17, 26, 21, 19, 19, 10, 23, 28. Public TitleSize As Integer Public MostValves() As Integer Public TotalValves As Integer Public TitleBlockSize As Integer Function ConvertToLetter(iCol As Integer) As String Dim iAlpha As Integer Dim iRemainder As Integer iAlpha = Int(iCol / 27) iRemainder = iCol - (iAlpha * 26) If iAlpha > 0 Then ConvertToLetter = Chr(iAlpha + 64) End If If iRemainder > 0 Then ConvertToLetter = ConvertToLetter & Chr(iRemainder + 64) End If End Function Sub ManualValve() 'On Error GoTo ErrHandler 'On Error Resume Next Worksheets(1).Activate ActiveSheet.Name = "Valve List" ActiveSheet.Cells.Clear PnIDPage = InputBox("How many pages are on your P&ID?") 'Values for Number of Pages: 14 Dim i As Integer TotalValves = 0 ReDim MostValves(PnIDPage) For i = 0 To PnIDPage - 1 ValveCount = InputBox("How many valves are on page " & i + 1 & " ?") 'Values for valves: 41, 26, 19, 28, 26, 28, 17, 26, 21, 19, 19, 10, 23, 28 If IsNumeric(ValveCount) Then MostValves(i) = ValveCount TotalValves = TotalValves + ValveCount Else MsgBox ("You did not enter a valid number") 'GoTo ErrHandler End If Next i Dim Title As Variant Response = MsgBox(prompt:="Do you want to use the default titleblock? (Count, Valve, Module, Note)", Buttons:=vbYesNo) If Response = vbYes Then Title = Array("Count", "Valve", "Module", "Note") TitleSize = UBound(Title, 1) - LBound(Title, 1) + 1 Else Title = Array("Count", "Valve", "Module") TitleSize1 = UBound(Title, 1) - LBound(Title, 1) + 1 XtraCol = InputBox("How many extra columns would you like to add?") ReDim Preserve Title(XtraCol + TitleSize1 - 1) TitleSize = UBound(Title, 1) - LBound(Title, 1) + 1 For i = TitleSize1 + 1 To TitleSize XtraTitle = InputBox("Extra Title " & i & "?") Title(i - 1) = XtraTitle Next i End If Dim TitleBlock As Variant TitleBlock = Array("Project Number", "Project Name", "By", "Rev", "Date") TitleBlockSize = UBound(TitleBlock, 1) - LBound(TitleBlock, 1) + 1 Range(ConvertToLetter(1) & "1:" & ConvertToLetter(1) & TitleBlockSize) = Application.Transpose(TitleBlock) Dim Maximum As Integer Dim ValveNum() As Integer Dim TempSize As Integer TempSize = 1 Maximum = WorksheetFunction.Max(MostValves) + 1 For i = 0 To PnIDPage - 1 Do Until MostValves(i) <> 0 i = i + 1 Loop ReDim ValveNum(MostValves(i)) For j = 0 To MostValves(i) ValveNum(j) = j + 1 Next j MsgBox TempSize If i Mod 2 = 0 Then Worksheets(1).Range(ConvertToLetter(TempSize) & TitleBlockSize + 2 & ":" & ConvertToLetter(TempSize + TitleSize - 1) & Maximum + TitleBlockSize).Interior.ColorIndex = 42 Else 'This is where I encounter the run-time error Worksheets(1).Range(ConvertToLetter(TempSize) & TitleBlockSize + 2 & ":" & ConvertToLetter(TempSize + TitleSize - 1) & Maximum + TitleBlockSize).Interior.ColorIndex = 43 End If Worksheets(1).Range(ConvertToLetter(TempSize) & TitleBlockSize + 2 & ":" & ConvertToLetter(TempSize) & CStr(MostValves(i) + 1 + TitleBlockSize)). _ Resize(MostValves(i), 1) = Application.Transpose(ValveNum) Worksheets(1).Range(ConvertToLetter(TempSize + 2) & TitleBlockSize + 2 & ":" & ConvertToLetter(TempSize + 2) & CStr(MostValves(i) + 1 + TitleBlockSize)) = "00" & CStr(i + 1) Worksheets(1).Range(ConvertToLetter(TempSize) & TitleBlockSize + 1 & ":" & ConvertToLetter(TempSize + TitleSize - 1) & TitleBlockSize + 1) = Title TempSize = TempSize + TitleSize Worksheets(1).Range(ConvertToLetter(TempSize - 1) & TitleBlockSize + 1 & ":" & ConvertToLetter(TempSize - 1) & Maximum + TitleBlockSize). _ Borders(xlEdgeRight).Weight = xlMedium Next i Cells(1, 4) = "Total Valve Count" Cells(1, 5) = TotalValves Range("A1:" & ConvertToLetter(TempSize) & Maximum + TitleBlockSize).HorizontalAlignment = xlCenter Range("A1:A" & TitleBlockSize).HorizontalAlignment = xlLeft Columns("A:" & ConvertToLetter(TempSize)).AutoFit Range("A1:" & ConvertToLetter(TempSize) & TitleBlockSize + 1).Font.Bold = True Range("A" & TitleBlockSize + 1 & ":" & ConvertToLetter(TempSize - 1) & TitleBlockSize + 1).Interior.ColorIndex = 1 Range("A" & TitleBlockSize + 1 & ":" & ConvertToLetter(TempSize - 1) & TitleBlockSize + 1).Font.Color = vbWhite Range("A" & Maximum + TitleBlockSize & ":" & ConvertToLetter(TempSize - 1) & Maximum + TitleBlockSize). _ Borders(xlEdgeBottom).Weight = xlMedium 'ErrHandler: 'MsgBox "An error has occurred. The macro will end." End Sub
The problem does not depend on your Valve, but on your ConvertToLetter function. In fact, at some point the error occurs because the function returns an invalid range letter: input: iCol = 53 return: "A[" Clearly, when you try to call the Range("A[2"), this raises the exception. The code inside your function is not solid because converts the number into letter with: ConvertToLetter = Chr(iAlpha + 64) The Chr() function returns the value associated to the index from the characters collection, which is a unique chars list and cannot be used as you try to do there. I would just replace your ConvertToLetter function with a more solid one, such as the following: Function ConvertToLetter(iCol As Integer) As String Dim vArr vArr = Split(Cells(1, iCol).Address(True, False), "$") ConvertToLetter = vArr(0) End Function ...which has been kindly provided by brettdj in one of his precious answers (don't forget to give him an upvote for this piece of gold ;). P.s. note that this explain also why a low number would not raise the exception: as long as the number is small, your function doesn't need to append a second letter to the output so it remains consistent. But as soon as it has to do that, CRASH ;) Use the above function, it's way safer because it just retrieves the Range address from the Cells object. Your code will work fine once you will replace your old function with the new one above.
How to print N number of primes in Visual basic (forms)?
I have this visual basic code to receive user input and print out that many primes. For instance if a user inputs 5, the output should be: 1, 3, 5, 7, 11. But I found difficulty with it.Here is my code: Dim i, n, input, currentPrime As Integer Dim Wrap As String = Chr(10) & Chr(13) input = txtInput.Text currentPrime = 1 txtAns.Text = "Prime Numbers are : " & Wrap Do While (currentPrime <= input) For i = currentPrime To input For j = 2 To Fix(i / 2) + 1 If i Mod j = 0 Then n = 1 End If Next If n = 1 Then n = 0 Else txtAns.Text = txtAns.Text & Wrap & i & " is a prime number " & Wrap End If Next currentPrime += 1 Loop
Try this... Dim i, n, input As Integer Dim Wrap As String = Chr(10) & Chr(13) input = txtInput.Text Dim found = 0 Dim output = "Prime Numbers are : " & Wrap While found < input i = i + 1 For j = 2 To Fix(i / 2) + 1 If i Mod j = 0 Then n = 1 End If Next If n = 1 Then n = 0 Else output = output & Wrap & i & " is a prime number " & Wrap found = found + 1 End If End While txtAns.Text = output