Split function for long text fails with VALUE! error - vba

I am using a function that i saw here on Stackoverflow:
Function EXTRACTELEMENT(Txt, n, Separator) As String
EXTRACTELEMENT = Split(Application.Trim(Txt), Separator)(n - 1)
End Function
It was spliting an array of data, like this:
sRN LMDscandata sRA LMDscandata 1 1 F97BBF 0 0 6D2A 6D2D 71F5A0FA 71F5FD85 0 0 7 0 0 1388 168 0 1 DIST1 3F800000 00000000 D9490 1388 5 6E2 6DC 6E3 6ED 6E1 0 0 0 0 0 0
But when i tried to increase the amount of data:
sRN LMDscandata sRA LMDscandata 1 1 F97BBF 0 0 FCDF FCE2 9DC90606 9DC9637B 0 0 7 0 0 1388 168 0 1 DIST1 3F800000 00000000 C3500 1388 3D 525 50B 518 508 51D 50A 51A 502 514 50F 502 51C 50E 51C 50E 4FF 509 505 50B 4F9 505 51B 513 516 501 50F 509 4FE 505 508 50C 507 50C 50E 51A 511 514 528 511 519 524 52E 526 522 524 535 534 52E 527 52F 52E 53D 52F 550 535 547 548 559 551 557 558 0 0 0 0 0 0
An error is occuring and the VBA returns an error window and no data is split. How can I fix it?
This is the full code, I am coding it to test a sensor output, where I receive some important data in hex & ascii and then transform to dec and make some graphs. This is the function that convert the values.
If someone can also give some tips on the Sub, I would appreciate it.
Sub ler()
Dim ncell
Dim vArr, col
Dim counter, elem_end As Integer
Dim rng1, rng2 As String
Set ascii = ThisWorkbook.Worksheets("ASCII")
Set medidas = ThisWorkbook.Worksheets("Medidas")
'Valor da última linha preenchida da coluna A'
ncell = ascii.Range("A65536").End(xlUp).Row
'Número de elementos'
elem_end = ascii.Range("B" & ncell).Value
For counter = 1 To elem_end
counterplus = counter + 2
vArr = Split(Cells(1, counterplus).Address(True, False), "$")
Col_Letter = vArr(0)
col = Col_Letter
Let rng1 = col & ncell
Let rng2 = "A" & ncell
ascii.Range(rng1).NumberFormat = "#"
ele = EXTRACTELEMENT(ascii.Range(rng2), counter, " ")
ascii.Range(rng1).FormulaR1C1 = ele
Next
With ascii.Range(Cells(ncell, 1), Cells(ncell, counterplus))
Set dist = .Find("DIST1", LookIn:=xlValues)
If Not dist Is Nothing Then
firstAddress = dist.Address
Do
dist1 = firstAddress
Set dist = .FindNext(dist)
Loop While Not dist Is Nothing And dist.Address <> firstAddress
End If
End With
data_col = ascii.Range(dist1).Column + 5
data_num = ascii.Cells(ncell, data_col).Value
dec_num = CLng("&H" & data_num)
medidas.Range("A" & ncell).Value = dec_num
For counter2 = 1 To data_num
asc_value = ascii.Cells(ncell, data_col + counter2).Value
Dec = CLng("&H" & asc_value)
medidas.Cells(ncell, counter2 + 1).Value = Dec
Next
End Sub
In Column B, there is a function that calculates the number of elements of the data in column A

You need to declare the variables, you are getting a Type mismatch, at least the first needs to be declared.
Function EXTRACTELEMENT(Txt As String, n As Long, Separator As String) As String
EXTRACTELEMENT = Split(Application.Trim(Txt), Separator)(n - 1)
End Function

Related

Test if a permutation of a number exists in a collection

I'm trying to list all numbers with 3 digits where the individual digits sum to a given number.
So far I can return a list of all numbers using this Visual Basic code:
target = 17
i = 1
j = 1
k = 1
Do While i < 10
Do While j < 10
Do While k < 10
r = i + j + k
If r = target Then
If i <> j And j <> k And k <> i Then
lsNumbers.Add(i & j & k )
End If
End If
k += 1
Loop
If k = 10 Then k = 1
j += 1
Loop
If j = 10 Then j = 1
i += 1
Loop
But I want only unique, non repeating combinations.
For example for the target number 17:
179, 197, 269, 278, 287...
I want to be able to test the current number before I add it to the list, to check if it is a combination of a number already in the list - so 197 would fail because of 179, and 287 would fail because of 278
Observations
Just curious, is excluding the 0 digit on purpose?
To iterate through the possible digits, a well suited instruction pair is FOR NEXT. Definitely simpler than the DO WHILE that you used.
Loop
If k = 10 Then k = 1
Loop
If j = 10 Then j = 1
Upon loop completion, the iterator is sure to contain 10. The IF is redundant.
Solution
In order to check if a number, that obeys the condition, is unique in the sense that it is not composed of the same 3 digits as an already validated number, you could consult a 3-D array. If the new number corresponds to a non-zero element in this array, it means that the new number would be using the same digits as an earlier number. That's reason to reject it.
Next code runs in QBasic. You'll have no trouble rewriting it for Visual BASIC.
DIM r%(1 TO 9, 1 TO 9, 1 TO 9)
FOR i% = 1 TO 9
FOR j% = 1 TO 9
FOR k% = 1 TO 9
r%(i%, j%, k%) = 0
NEXT
NEXT
NEXT
target% = 17
FOR i% = 1 TO 9
FOR j% = 1 TO 9
FOR k% = 1 TO 9
IF i% + j% + k% = target% THEN
IF r%(i%, j%, k%) = 0 THEN
PRINT i% * 100 + j% * 10 + k%; " ";
r%(i%, j%, k%) = 1 ' Could do without this one because of the ascending order
r%(i%, k%, j%) = 1
r%(j%, i%, k%) = 1
r%(j%, k%, i%) = 1
r%(k%, i%, j%) = 1
r%(k%, j%, i%) = 1
END IF
END IF
NEXT
NEXT
NEXT
This is my output of valid numbers:
179 188 269 278 359 368 377 449 458 467 557 566

Using variables instead of values

I'm having a problem with my existing code.
This code works fine,
Public Function jewel_intrate_new(ByVal duration As Integer) As String
Select Case duration
Case 0 : max2 = "0%"
Case 1 To 33 : max2 = "3.5%"
Case 34 To 63 : max2 = "9%"
Case 64 To 93 : max2 = "14.5%"
Case 94 To 123 : max2 = "20%"
Case 124 To 153 : max2 = "25.5%"
Case 154 To 183 : max2 = "31%"
Case 184 To 213 : max2 = "36.5%"
Case 214 To 243 : max2 = "42%"
Case 244 To 273 : max2 = "47.5%"
Case 274 To 303 : max2 = "53%"
Case 304 To 333 : max2 = "58.5%"
Case 334 To 363 : max2 = "64%"
Case 364 To 393 : max2 = "69.5%"
Case 394 To 423 : max2 = "75%"
Case 424 To 453 : max2 = "80.5%"
Case 454 To 483 : max2 = "86%"
Case 484 To 513 : max2 = "91.5%"
Case 514 To 543 : max2 = "97%"
Case 544 To 573 : max2 = "102.5%"
Case 574 To 603 : max2 = "108%"
Case 604 To 633 : max2 = "113.5%"
Case 634 To 663 : max2 = "119%"
Case 664 To 693 : max2 = "124.5%"
End Select
Return max2
End Function
All i want is to make my app as editable the values so i update the code as follows:
Private Sub Button1_Click_1(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
Dim x As Double = 3.5 * 100, z As Integer, duration As Integer = TextBox1.Text
Dim jj As Double = 3.5
Select Case duration
Case 0
jj = 0
Case 1 To 33
jj = 3.5
Case 34 To 9999
z = (duration / 30)
For i As Integer = 1 To z
jj += 3.5 + 2 'this will be editable in database.
Next
End Select
Label1.Text = jj & "%"
End Sub
But they don't have the same output.
Is there anyway to make my function simpler and shorter?
monthly interest is 3.5%
penalty interest is 2% after 33 days
monthly is 30 days plus 3 days grace period
These results should match your Select Case but you can pass in any interest rate or penalty interest. Import System.Math. Test against your Select Case.
Private Function Calculate(ByVal Duration As Integer, InterestRate As Double, PenaltyRate As Double) As Double
Dim Rate As Double
Dim Multiplier As Integer = CInt(Math.Ceiling((Duration - 3) / 30))
Rate = Multiplier * InterestRate + PenaltyRate * (Multiplier - 1)
Return Rate
End Function

Open PDF, save DOCX bugs out after a few dozen documents and outputs garbled/corrupted files

I have a few thousand PDF files that I needs to convert to DOCX. I wrote the following macro:
Sub convertPDFtoDOCX()
'
' convertPDFtoDOCX Macro
'
'
Dim docDirectory As String
Dim pdfDirectory As String
Dim docPath As String
Dim doc As Document
docDirectory = "C:\Users\<USER>\DOCX\"
pdfDirectory = "C:\Users\<USER>\PDF\"
pdfFile = Dir(pdfDirectory & "*.*")
Do While pdfFile <> ""
docPath = docDirectory & pdfFile & ".docx"
Set doc = Documents.Open(FileName:=pdfDirectory & pdfFile)
ActiveDocument.SaveAs2 FileName:=docPath, FileFormat:=wdFormatXMLDocument
Documents.Close
pdfFile = Dir
Loop
End Sub
It works fine for the first few dozen documents, but then starts outputting "corrupted files", that aren't docx and can't be opened with a PDF viewer either. There is no error message when it starts bugging out. The problem doesn't come from the PDF files, since if I stop the macro and start it again on the same documents, they are correctly converted the second time.
"Corrupted" files looks like this:
%PDF-1.5
%µµµµ
1 0 obj
<</Type/Catalog/Pages 2 0 R/Lang(fr-FR) /StructTreeRoot 91 0 R/MarkInfo<</Marked true>>>>
endobj
2 0 obj
<</Type/Pages/Count 21/Kids[ 3 0 R 27 0 R 31 0 R 42 0 R 44 0 R 46 0 R 48 0 R 55 0 R 59 0 R 61 0 R 63 0 R 65 0 R 67 0 R 69 0 R 71 0 R 73 0 R 75 0 R 77 0 R 79 0 R 81 0 R 88 0 R] >>
endobj
3 0 obj
<</Type/Page/Parent 2 0 R/Resources<</Font<</F1 5 0 R/F2 9 0 R/F3 11 0 R/F4 16 0 R/F5 18 0 R/F6 20 0 R/F7 25 0 R>>/ExtGState<</GS7 7 0 R/GS8 8 0 R>>/ProcSet[/PDF/Text/ImageB/ImageC/ImageI] >>/MediaBox[ 0 0 595.2 841.8] /Contents 4 0 R/Group<</Type/Group/S/Transparency/CS/DeviceRGB>>/Tabs/S/StructParents 0>>
endobj
4 0 obj
<</Filter/FlateDecode/Length 4428>>
stream
xœ­\Ën7Ýð?Ô.Ý ¨Ä7«‚ ¹%e4ð+²’Y$Yt¤¶£A,9RÛÈüÕ|Æ|ÆìÙäæ^²ÈzðQ-¦ È]U¼$//:<yØÞ¾__o«££Ã“ív}ýóæ¦úþðÅýv{ÿñÇë}Ú¾]¸½[ooïï
What causes the issue and how can I fix it?
I use Word 2016 on Windows 10.
I don't think you can fix the issue without a patch from Microsoft. Meanwhile, you can move your code to run outside Word and create a new Word.Application object for each iteration.

Nested FOR loops in VBA

I am attempting to impliment a nested FOR loop in excel. Then interior loop does not seem to be executing in the code. Is the error syntatical? What's going on here?
Sub Statistics()
Dim cc As Integer
Dim i As Integer
i = 4
cc = 0
For cc = 0 To 4
For i = 4 To -4
If Sheets("Significance").Cells(4 + cc, 13 - i) = 1 Then Sheets("Output Database").Cells(8 + currevent, 7 + cc) = i
Next i
Next cc
'Rates
i = 4
cc = 0
For cc = 0 To 4
For i = 4 To -4
If Sheets("Significance").Cells(14 + cc, 13 - i) = 1 Then Sheets("Output Database").Cells(8 + currevent, 23 + cc) = i
Next i
Next cc
End Sub
The loop referring to the i variable needs to specify that i is decreasing:
For i = 4 To -4 Step -1

WorksheetFunction.Match not working

Here is an excerpt from my data:
------+------+------+------+------+
| A | B | C | D |
------+------+------+------+------+
1 | 10 20 25 30
2 | 152 181 195 210
and my code:
Dim xrng as range, yrng as range, offset as integer
set xrng = Sheets("Sheet1").Range("A1:D1")
set yrng = Sheets("Sheet1").Range("A2:D2")
offset = WorksheetFunction.Match(23, xrng , 1) - 1
Why does running this result in a 1004 error: Unable to get the match property of the worksheetfunction class? How can I fix it?
EDIT: Detailed problem
Okay, I have written a function that does interpolation:
Public Function interpolate(intvalue_X As Double, xrange As range, yrange As range) As Double
....this is just an excerpt:
Dim offst As Integer
offst = WorksheetFunction.Match(intvalue_X, xrange, 1) - 1 'find the offset of the nearest value
---
End Function
With the following data and call, it works fine and returns the correct answer:
(don't mind the variables' who's declarations aren't shown - they have been declared at this point, it's just not copied)
Set intXrng = Sheets("Tables").range("B32:G32")
If beltWidth >= 46 And beltWidth <= 122 And conveyerCenter >= 7.6 And conveyerCenter <= 152.4 Then 'dan kan jy die tabel gebruik
m = interpolate(beltWidth, intXrng, Sheets("Tables").range("B44:G44"))
c = interpolate(beltWidth, intXrng, Sheets("Tables").range("B45:G45"))
powerX = m * conveyerCenter + c
Else
MsgBox "Unable to use the power x-factor table.", vbCritical
End If
Now, when I use the same function, but with this data and call, it gives the error:
Set intXrng = Sheets("Tables").range("F4:I4")
angleSurcharge = 23
capacityTable = interpolate(angleSurcharge, intXrng, Sheets("Tables").range("F7:I7"))
Your values are not stored as strings because they are in a table header. Table headers are always read as strings regardless of their format.
You can convert all values to the Doubles before passing it to Worksheet.Match to fix the bug.
Dim offst As Integer
Dim arry As Variant
ReDim arry(1 To 1, 1 To xrange.Columns.Count)
For i = 1 To xrange.Columns.Count
arry(1, i) = CDbl(xrange.Cells(1, i).Value)
Next
offst = WorksheetFunction.Match(intvalue_X, arry, 1) - 1 'find the offset of the nearest value