Editing a string in Excel VBA userform using special characters - excel

I'm trying to write a program for a userform in excel for editing chart title and other things. I want write a code that uses special characters i.e. {like this} and changes the text inside the cutely brackets to subscript and I want to able to do this multiple times:
The following code this but only for the first occurrence.
Public Font_Name As String, Font_Style As String, Half_Height As Integer
Sub CommandButton1_Click()
'********************Define Standardized Plot Settings******************
Font_Name = "Arial"
Font_Style = "Normal"
Title_Font_Size = 28
Axes_Label_Font_Size = 22
Tick_Lable_Font_Size = 20
PlotArea_Border_Color_R = 0
PlotArea_Border_Color_G = 0
PlotArea_Border_Color_B = 0
PlotArea_Border_Weight = 3
PlotArea_Border_Weight_Pass = PlotArea_Border_Weight
Grid_Color_R = 150
Grid_Color_G = 150
Grid_Color_B = 150
Grid_Weight = 2
Grid_Weight_Pass = Grid_Weight
'*****************End Define Standardized Plot Settings*****************
'****************************Format the plot********************************
'----------------------------Format the Title-------------------------------
'*****Searches Char Title for {} and replaces everything indside as subscript***
With ActiveChart
.HasTitle = True
.ChartTitle.Text = Me.Chart_Title.Text
.ChartTitle.Characters.Font.Name = Font_Name
.ChartTitle.Characters.Font.FontStyle = Font_Style
.ChartTitle.Characters.Font.Size = Title_Font_Size 'works
If Me.FontOveride <> "" Then
.ChartTitle.Characters.Font.Size = Me.FontOveride
Else
.ChartTitle.Characters.Font.Size = Title_Font_Size 'works
End If
searchString = Me.Chart_Title.Text
Char1 = "{"
Char2 = "}"
For i = 1 To Len(searchString)
If Mid(searchString, i, 1) = Char1 Then
startPos = i
Exit For
Else:
End If
Next i
For j = 1 To Len(searchString)
If Mid(searchString, j, 1) = Char2 Then
endPos = j
Exit For
Else:
End If
Next j
If startPos >= 1 Or endPos >= 1 Then
.ChartTitle.Characters(startPos, endPos - startPos).Font.Subscript = True
.ChartTitle.Characters(startPos, 1).Delete
.ChartTitle.Characters(endPos - 1, 1).Delete
Else:
End If
End With
'***************************************************************************
'***************************************************************************
'----------------------------Format the X Axis-------------------------------
With ActiveChart.Axes(xlCategory)
.HasTitle = True
.AxisTitle.Characters.Text = Me.X_Axis_Title
.AxisTitle.Characters.Font.Name = Font_Name
.AxisTitle.Characters.Font.FontStyle = Font_Style
.AxisTitle.Characters.Font.Size = Axes_Label_Font_Size
.TickLabels.Font.Name = Font_Name
.TickLabels.Font.FontStyle = Font_Style
.TickLabels.Font.Size = Tick_Lable_Font_Size
.MajorTickMark = xlTickMarkNone
.MinimumScale = Me.X_Axis_Start
.MaximumScale = Me.X_Axis_Stop
.MajorUnit = Me.X_Axis_Step
.CrossesAt = Me.X_Axis_Start
.HasMajorGridlines = True
.MajorGridlines.Border.Color = RGB(Grid_Color_R, Grid_Color_G, Grid_Color_B)
.MajorGridlines.Border.Weight = Grid_Weight_Pass
.Border.Color = vbBlack
'*****Searches X-Axis for {} and replaces everything indside as subscript*******
searchString = Me.X_Axis_Title
Char1 = "{"
Char2 = "}"
For i = 1 To Len(searchString)
If Mid(searchString, i, 1) = Char1 Then
Pos1 = i
Exit For
Else:
'End If
End If
Next i
For j = 1 To Len(searchString)
If Mid(searchString, j, 1) = Char2 Then
Pos2 = j
Exit For
Else:
'End If
End If
Next j
If Pos1 >= 1 And Pos2 >= 1 Then
.AxisTitle.Characters(Pos1, Pos2 - Pos1).Font.Subscript = True
.AxisTitle.Characters(Pos1, 1).Delete
.AxisTitle.Characters(Pos2 - 1, 1).Delete
Else:
End If
End With
'----------------------------Format the Y Axis-------------------------------
With ActiveChart.Axes(xlValue)
.HasTitle = True
.AxisTitle.Characters.Text = Me.Y_Axis_Title
.AxisTitle.Characters.Font.Name = Font_Name
.AxisTitle.Characters.Font.FontStyle = Font_Style
.AxisTitle.Characters.Font.Size = Axes_Label_Font_Size
.TickLabels.Font.Name = Font_Name
.TickLabels.Font.FontStyle = Font_Style
.TickLabels.Font.Size = Tick_Lable_Font_Size
On Error GoTo Skip
Decimal_Position = Len(Me.Y_Axis_Step.Text) - WorksheetFunction.Search(".", Me.Y_Axis_Step.Text)
Format_String = "#,##0." & WorksheetFunction.Rept("0", Decimal_Position)
.TickLabels.NumberFormat = Format_String
GoTo Skip2
Skip:
On Error GoTo 0
.TickLabels.NumberFormat = "#,##0"
Skip2:
.MajorTickMark = xlTickMarkNone
.MinimumScale = Me.Y_Axis_Start
.MaximumScale = Me.Y_Axis_Stop
.MajorUnit = Me.Y_Axis_Step
.CrossesAt = Me.Y_Axis_Start
.HasMajorGridlines = True
.MajorGridlines.Border.Color = RGB(Grid_Color_R, Grid_Color_G, Grid_Color_B)
.MajorGridlines.Border.Weight = Grid_Weight_Pass
.Border.Color = vbBlack
'*****Searches Y Axis for {} and replaces everything indside as subscript*******
searchString = Me.Y_Axis_Title
Char1 = "{"
Char2 = "}"
For i = 1 To Len(searchString)
If Mid(searchString, i, 1) = Char1 Then
Pos3 = i
Exit For
Else:
'End If
End If
Next i
For j = 1 To Len(searchString)
If Mid(searchString, j, 1) = Char2 Then
Pos4 = j
Exit For
Else:
'End If
End If
Next j
If Pos3 >= 1 And Pos4 >= 1 Then
.AxisTitle.Characters(Pos3, Pos4 - Pos3).Font.Subscript = True
.AxisTitle.Characters(Pos3, 1).Delete
.AxisTitle.Characters(Pos4 - 1, 1).Delete
Else:
End If
End With
'****************************End Format the Plot*******************************

You can use regular expressions with the pattern {[\w]*}.
If you want to use early binding, then it requires reference to Microsoft VBScript Regular Expressions 5.5.
RegEx will give you, in addition to other information the start position & length of each substring, which you can then use to apply the subscript or other formatting as required.
Sub regTest()
Dim R As Object 'New RegExp
Dim matches As Object 'MatchCollection
Dim m As Variant
Dim str As String
Set R = CreateObject("VBScript.RegExp")
str = "hello {world} this is my {title}"
R.Pattern = "{[\w]*}"
R.Global = True
R.IgnoreCase = True
If R.test(str) Then
Set matches = R.Execute(str)
For Each m In matches
Debug.Print m.Value
Debug.Print "Starts at: " & m.FirstIndex
Debug.Print "Lenght: " & m.Length
Next
End If
End Sub

Related

Compare two words and return the number of letter differences

The macro is written to return the number of letter differences (insertions, replacements, or deletions) of two words (case sensitive).
It is suppose to format and output in phrases
1-2 Letters off,
1-2 Letters off, Same Starting Letter,
3-4 Letters off,
3-4 Letters off, Same Starting Letter and
5 or more letters off, CHECK
It is only outputting
1-2 Letters off, Same Starting Letter,
3-4 Letters off, Same Starting Letter and
5 or more Letters off, CHECK
I would like the formatting to stay the same for now.
Sub Test_HW_Formatter()
'declare the variables
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim testNames As Integer
Dim responses As Integer
Dim printRow As Integer
Dim name As String
Dim count As Integer
Dim coding As String
Dim statLetter As Boolean
Dim tempCount As Integer
Dim tempResp As String
'the queues for the entries, the respective counts, and respective codes
Dim words As Object
Set words = CreateObject("System.Collections.Queue")
Dim counts As Object
Set counts = CreateObject("System.Collections.Queue")
Dim codes As Object
Set codes = CreateObject("System.Collections.Queue")
'set the variables
printRow = 3
testNames = Selection.Columns.count
responses = Selection.Rows.count - 1
Cells(4, 3).Value = Selection(4)
startLetter = True
'make the header
Cells(1, 1).Value = "Name"
Cells(1, 2).Value = "Response"
Cells(1, 3).Value = "Count"
Cells(1, 4).Value = "Code"
Cells(1, 5).Value = "Agency close matches"
Cells(1, 6).Value = "N=" + Trim(Str(responses))
Cells(1, 6).Interior.Color = RGB(255, 255, 204)
Cells(1, 6).HorizontalAlignment = xlCenter
For i = 1 To 5
Cells(1, i).Interior.Color = RGB(1, 139, 175)
Cells(1, i).Font.Color = RGB(255, 255, 255)
Cells(1, i).HorizontalAlignment = xlCenter
Next i
'get the information and put it in the queues
For i = 0 To (testNames - 1)
name = Selection(i + 1).Value
For j = 1 To responses
count = 1
If Not Selection(j * testNames + i + 1) = "" Then
For k = 1 To (responses - j)
If Not Selection((j + k) * testNames + i + 1).Value = "" Then
If Trim(UCase(Selection(j * testNames + i + 1).Value)) = Trim(UCase(Selection((j + k) * testNames + i + 1).Value)) Then
count = count + 1
Selection((j + k) * testNames + i + 1).Value = ""
End If
End If
Next k
'get the coding
coding = ""
ld = Levenshtein(name, Trim(UCase(Selection(j * testNames + i + 1))))
If Mid(testName, 1, 1) = Mid(sample, 1, 1) Then
startLetter = True
Else
startLetter = False
End If 'if for starting letter
Select Case ld
Case 0
coding = "Exact Match"
Case 1
If startLetter = True Then
coding = "1-2 Letters off, Same Starting Letter"
Else
coding = "1-2 Letters off"
End If
Case 2
If startLetter = True Then
coding = "1-2 Letters off, Same Starting Letter"
Else
coding = "1-2 Letters off"
End If
Case 3
If startLetter = True Then
coding = "3-4 Letters off, Same Starting Letter"
Else
coding = "3-4 Letters off"
End If
Case 4
If startLetter = True Then
coding = "3-4 Letters off, Same Starting Letter"
Else
coding = "3-4 Letters off"
End If
Case Else
coding = "5 or more Letters off, CHECK"
End Select
'enqueue the values
tempResp = UCase(Mid(Selection(j * testNames + i + 1).Value, 1, 1)) + LCase(Mid(Selection(j * testNames + i + 1).Value, 2, Len(Selection(j * testNames + i + 1).Value)))
words.enqueue (tempResp)
counts.enqueue (count)
codes.enqueue (coding)
End If 'if the cell is not blank
Next j
'print the queues from the ith column
'start the section header
Cells(printRow, 1).Value = name
Cells(printRow, 1).Font.Color = RGB(255, 255, 255)
For k = 1 To 5
Cells(printRow, k).Interior.Color = RGB(1, 139, 175)
Cells(printRow, k).HorizontalAlignment = xlCenter
Next k
tempCount = counts.count
Cells(150, 20 + i).Value = tempCount
For k = 1 To tempCount
Cells(printRow + k, 2).Value = words.dequeue
Cells(printRow + k, 3).Value = counts.dequeue
Cells(printRow + k, 4).Value = codes.dequeue
If Cells(printRow + k, 4).Value = "Exact Match" Then
Cells(printRow + k, 4).Interior.Color = RGB(236, 239, 218)
End If
Next k
printRow = printRow + tempCount + 2
Next i
End Sub
Edited to add counting replicates of the same name, and skip empty values:
Sub Test_HW_Formatter()
Dim arr, numReps As Long, ws As Worksheet, col As Long, c As Range
Dim nm As String, rep As Long, cmp As String
Dim i As Long, dict As Object, tmp
arr = Selection.Value 'inputs
numReps = UBound(arr, 1) - 1 'reps per column
Set ws = Selection.Parent 'sheet with selection
With ws.Range("A1:E1")
.Value = Array("Name", "Response", "Count", "Code", "Agency Close match")
doHeaders .Cells
End With
ws.Range("F1").Value = "N=" & numReps
Set c = ws.Range("A3") 'start of output sections
For col = 1 To UBound(arr, 2) 'loop columns of selection
nm = arr(1, col)
c.Value = nm
doHeaders c.Resize(1, 5) 'format headers
i = 0
Set dict = CreateObject("scripting.dictionary")
For rep = 1 To numReps 'loop values to compare
cmp = arr(rep + 1, col)
If Len(cmp) > 0 Then
If Not dict.exists(cmp) Then
i = i + 1
dict.Add cmp, i
c.Offset(i, 1).Value = cmp
c.Offset(i, 2) = 1
c.Offset(i, 3).Value = MatchCoding(nm, cmp) 'now in separate function
Else
'increment count for existing line
c.Offset(dict(cmp), 2).Value = c.Offset(dict(cmp), 2).Value + 1
End If
End If 'not zero-length
Next rep
Set c = c.Offset(i + 2, 0) 'next set
Next col
End Sub
'return a string summarizing how closeley two terms match
Function MatchCoding(nm As String, cmp As String)
Dim ld As Long, firstMatch As Boolean
firstMatch = (Left(nm, 1) = Left(cmp, 1))
ld = Levenshtein(nm, cmp)
Select Case ld
Case 0: MatchCoding = "Exact Match"
Case 1, 2: MatchCoding = "1-2 Letters off"
Case 3, 4: MatchCoding = "3-4 Letters off"
Case Else: MatchCoding = "5 or more Letters off, CHECK"
End Select
If ld > 0 And ld < 5 Then MatchCoding = MatchCoding & _
IIf(firstMatch, ", Same Starting Letter", "")
End Function
'utility sub for formatting headers
Sub doHeaders(rng As Range)
With rng
.Interior.Color = RGB(1, 139, 175)
.Font.Color = RGB(255, 255, 255)
.HorizontalAlignment = xlCenter
End With
End Sub

Gantt chart creation is causing program error

I have this VBA program that I created a long time ago. In its original document it work perfectly and outputs something that looks like the following:
However, when I copy the input sheet and VBA code to a new document that set up exactly the same it gives me a
Runtime error 13: type mismatch error
on the line that says EndTime = ActiveSheet.Cells(RowIndex, VAR5) about halfway down the code.
Public RESOL As Single
Public StepRow As Integer 'this is the start ROW for the STEP numbers
Public StepColumn As Integer 'this is the COLUMN for the STEP numbers
Public VAR3 As Integer 'this is the COLUMN for ABSOLUTE START
Public VAR4 As Integer 'this is the COLUMN for LINK
Public VAR5 As Integer 'this is the COLUMN for DURATION
Public VAR6 As Integer 'this is the COLUMN for the first time period
Public VAR7 As Integer ' this is the ROW for the labels
Public RowPos As Single
Public TotalTime As Single
Public x1 As Single
Public RowIndex As Integer
Public LastColumn As Integer
Public StartTime As Single
Public EndTime As Single
Public WindowSize As Single
Sub Chart()
StepRow = 5 ' starting row for step numbers
StepColumn = 2 ' this is the COLUMN for the STEP numbers
VAR3 = 4 ' this is the COLUMN for ABSOLUTE START
VAR4 = 5 ' this is the COLUMN for LINK
VAR5 = 6 ' this is the COLUMN for DURATION
VAR6 = 11 ' this is the COLUMN for the first time period
VAR7 = 3 ' this is the ROW for the labels.
RESOL = ActiveSheet.Cells(1, VAR3)
'when the resolution to .01 if less than .01
If RESOL < 0.01 Then
MsgBox ("Grid resolution must be at least .01")
Exit Sub
End If
LastColumn = VAR6
TotalTime = 0
RowIndex = StepRow
CheckNum = 1
Do
x = ActiveSheet.Cells(RowIndex, StepColumn)
' bomb if no step number present
If IsNumeric(x) = False Then
MsgBox ("Couldn't find a step number at position " & CheckNum)
Exit Sub
End If
If x < 1 Then
LastNum = CheckNum - 1
Exit Do
End If
If x <> CheckNum Then
MsgBox ("Step number does not match position" & CheckNum)
Exit Sub
End If
RowIndex = RowIndex + 1
CheckNum = CheckNum + 1
Loop
ActiveSheet.Lines.Delete
ActiveSheet.Range(Cells(VAR7, VAR6), Cells(VAR7, 256)).ClearContents
Application.ScreenUpdating = False
WindowSize = ActiveWindow.Zoom
ActiveWindow.Zoom = 100
RowIndex = StepRow
CheckNum = 1
Do
LinkPos = ActiveSheet.Cells(RowIndex, VAR4)
If Val(LinkPos) > LastNum Then
MsgBox ("Illegal LINK number for step " + CheckNum)
ActiveWindow.Zoom = WindowSize
Application.ScreenUpdating = True
Exit Sub
End If
If Val(LinkPos) < 1 Then
ActiveSheet.Cells(RowIndex, VAR4).Formula = Empty
End If
If Val(LinkPos) > 0 And Val(LinkPos) <= LastNum Then
ActiveSheet.Cells(RowIndex, VAR3).Formula = "NA"
End If
If CheckNum = LastNum Then
Exit Do
End If
CheckNum = CheckNum + 1
RowIndex = RowIndex + 1
Loop
CompletedSteps = 0
RowIndex = StepRow
CheckNum = 1
Do
AbsPos = ActiveSheet.Cells(RowIndex, VAR3)
If AbsPos <> "NA" And IsNumeric(AbsPos) = True Then
StartTime = Val(AbsPos)
EndTime = ActiveSheet.Cells(RowIndex, VAR5)
EndTime = EndTime + StartTime
Run ("DrawLine")
CompletedSteps = CompletedSteps + 1
End If
If CheckNum = LastNum Then
Exit Do
End If
CheckNum = CheckNum + 1
RowIndex = RowIndex + 1
Loop
NoOfTries = 1
Do
If CompletedSteps = LastNum Then
Exit Do
End If
RowIndex = StepRow
CheckNum = 1
Do
LinkTo = ActiveSheet.Cells(RowIndex, VAR4)
If Val(LinkTo) >= 1 And Val(LinkTo) <= LastNum Then
AbsPos = ActiveSheet.Cells(StepRow - 1 + LinkTo, VAR3)
If AbsPos <> "NA" And IsNumeric(AbsPos) = True Then
DurPos = ActiveSheet.Cells(StepRow - 1 + LinkTo, VAR5)
AbsPos = AbsPos + DurPos
StartTime = Val(AbsPos)
EndTime = ActiveSheet.Cells(RowIndex, VAR5)
EndTime = EndTime + StartTime
ActiveSheet.Cells(RowIndex, VAR3).Formula = StartTime
Run ("DrawLine")
Top1 = ActiveSheet.Cells(StepRow - 1 + LinkTo, VAR6).Top
Top2 = ActiveSheet.Cells(StepRow + LinkTo, VAR6).Top
RowPos2 = Top1 + ((Top2 - Top1) / 2)
Set mySheet = ActiveSheet
With mySheet.Shapes.AddLine(x1, RowPos, x1, RowPos2).Line
.DashStyle = msoLineDash
.ForeColor.RGB = RGB(0, 0, 0)
End With
CompletedSteps = CompletedSteps + 1
End If
End If
If CheckNum = LastNum Then
Exit Do
End If
CheckNum = CheckNum + 1
RowIndex = RowIndex + 1
Loop
If NoOfTries = LastNum Then
Exit Do
End If
NoOfTries = NoOfTries + 1
Loop
RowIndex = StepRow
CheckNum = 1
Do
LinkPos = ActiveSheet.Cells(RowIndex, VAR4)
If Val(LinkPos) > 0 And Val(LinkPos) <= LastNum Then
ActiveSheet.Cells(RowIndex, VAR3).Formula = Empty
End If
If CheckNum = LastNum Then
Exit Do
End If
CheckNum = CheckNum + 1
RowIndex = RowIndex + 1
Loop
CheckCol = VAR6
ColVal = RESOL
Do
ActiveSheet.Cells(VAR7, CheckCol).Formula = ColVal
If CheckCol >= LastColumn Then
Exit Do
End If
ColVal = ColVal + RESOL
CheckCol = CheckCol + 1
Loop
ActiveSheet.Cells(2, VAR3).Formula = TotalTime
Range("A1").Select
ActiveWindow.Zoom = WindowSize
Application.ScreenUpdating = True
End Sub
Sub Drawline()
If EndTime > TotalTime Then
TotalTime = EndTime
End If
Top1 = ActiveSheet.Cells(RowIndex, VAR6).Top
Top2 = ActiveSheet.Cells(RowIndex + 1, VAR6).Top
RowPos = Top1 + ((Top2 - Top1) / 2)
CheckCol = VAR6
ColTime = 0
Do
x1 = ActiveSheet.Cells(RowIndex, CheckCol).Left
If ColTime = StartTime Then
Exit Do
End If
If ColTime > StartTime Then
x2 = ActiveSheet.Cells(RowIndex, CheckCol - 1).Left
Span = x1 - x2
Differencial = (ColTime - StartTime) / RESOL
TimeOffset = Differencial * Span
x1 = x1 - TimeOffset
Exit Do
End If
ColTime = ColTime + RESOL
CheckCol = CheckCol + 1
Loop
CheckCol = VAR6
ColTime = 0
Do
y1 = ActiveSheet.Cells(RowIndex, CheckCol).Left
If ColTime = EndTime Then
Exit Do
End If
If ColTime > EndTime Then
y2 = ActiveSheet.Cells(RowIndex, CheckCol - 1).Left
Span = y1 - y2
Differencial = (ColTime - EndTime) / RESOL
TimeOffset = Differencial * Span
y1 = y1 - TimeOffset
Exit Do
End If
ColTime = ColTime + RESOL
CheckCol = CheckCol + 1
Loop
If CheckCol > LastColumn Then
LastColumn = CheckCol
End If
Set mySheet = ActiveSheet
With mySheet.Shapes.AddLine(x1, RowPos - 2, y1, RowPos - 2).Line
.DashStyle = msoLineSolid
.ForeColor.RGB = RGB(128, 0, 25)
.Weight = xlHairline
End With
With mySheet.Shapes.AddLine(x1, RowPos, y1, RowPos).Line
.DashStyle = msoLineSolid
.ForeColor.RGB = RGB(128, 0, 25)
.Weight = xlThick
End With
With mySheet.Shapes.AddLine(x1, RowPos + 2, y1, RowPos + 2).Line
.DashStyle = msoLineSolid
.ForeColor.RGB = RGB(128, 0, 25)
.Weight = xlHairline
End With
End Sub
Any help would be greatly appreciated. I have the two documents set up exactly the same so I can't figure out why its working on one, but not the other.
Edit: below is the state of the document when it errors out. It added all the "NA" to the start time column, but doesn't do that on the original sheet.
When I comment out the error it works, but prints the following where there are solid bars beneath the gantt chart and the starting bar is solid.

Grabbing Data From Workbook With Compiler Error

Compiler Error: End With Has No With. I know that this is wrong, and there is something in my code in where I am not calling it correctly that is making it mess up but I cannot find it. I'm just trying to grab information off of my sheet1 so that I can use it later on.
With ThisWorkbook.Sheets("Sheet1")
While (Counter <= 300)
Pcounter = .Cells(ACBoxCounter, 2)
If (Pcounter <> "") Then
ACounter = ACounter + 1
End If
ACBCounter = ACBCounter + 30
Wend
While (OverallACounter < ACounter)
Set objStream = CreateObject("ADODB.Stream")
objStream.Charset = "iso-8859-1"
objStream.Open
ExampleString = .Cells(Row2Counter + 22, 3)
ChooseM = Split(ExampleString, "-")(1)
If (ChooseM = "8")
M = "II"
P = 97
Label = .Cells(Row2Counter, 2)
ElseIf (ChooseM = "13") Then
Model = "A II"
P = 10
Label = "A6_" & .Cells(Row2Counter, 2)
ElseIf (ChooseM = "19") Then
M = "AC1I"
P = 56
Label = "A9_" & .Cells(Row2Counter, 2)
End If
OverallD = 0
Overall= 0
OverallB = 0
ChooseBoxType = Split(ExampleString, "-")(2)
If ((StrComp(ChooseB, "1") = 0) Or (StrComp(ChooseB, "1M") = 0)) Then
BoxInputT= "1 Phase"
ElseIf ((StrComp(ChooseB, "2") = 0) Or (StrComp(ChooseB, "2M") = 0)) Then
BoxInput= "2"
ElseIf ((StrComp(ChooseB ,"3") = 0) Or (StrComp(ChooseBo, "3M") = 0)) Then
BoxInput= "3"
End If
objStream.WriteText (" <" & .Cells(Row2Counter, 2).Text & ">" & vbLf)
Wend
End With
Compiler Error: End With Has No With

creating excel charts with dynamic data range in vb.net

I am creating an Excel pie and bar charts from exported data pragmatically. Here I need to pick the cell range dynamically. For example, after header name all data should be picked up until cell contains "TOTAL" line.
Below is my current code.
If String.IsNullOrEmpty(HttpContext.Current.Request.QueryString("oversight")) Then 'This is Summary Level
Dim worksheet2 As ExcelWorksheet = pkg.Workbook.Worksheets.Add("Chart - CY Consumable")
worksheet2.DefaultColWidth = 15
Dim consumableChart As OfficeOpenXml.Drawing.Chart.ExcelPieChart = worksheet2.Drawings.AddChart("ConsumableChart", OfficeOpenXml.Drawing.Chart.eChartType.Pie)
Dim r1, r2 As ExcelRange
r1 = worksheet.Cells("A6:A12") // here I want it to be selected dynamically after header and before the total line
r2 = worksheet.Cells("B6:B12")
consumableChart.Series.Add(r2, r1)
consumableChart.Style = OfficeOpenXml.Drawing.Chart.eChartStyle.Style2
consumableChart.Title.Text = "FY 2018 Consumable by Regional & Central Oversight Programs"
consumableChart.Legend.Remove()
consumableChart.SetPosition(1, 1, 1, 1)
consumableChart.SetSize(1040, 880)
consumableChart.DataLabel.ShowLeaderLines = True
consumableChart.DataLabel.ShowCategory = True
consumableChart.DataLabel.ShowPercent = True
Thanks in advance.
Dim totalRow As Integer
If ds.Tables.Count > 0 Then
Dim k As Integer = 0
For j As Integer = 0 To ds.Tables(0).Columns.Count - 1
If Not skip.Contains(j) Then
If columnNames.Count > 0 AndAlso columnNames.Count = (ds.Tables(0).Columns.Count - skip.Count) Then
strTitle = columnNames(k)
Else
strTitle = ds.Tables(0).Columns(j).ColumnName.Replace("_", " ")
End If
worksheet.Cells(p, k + 1).Value = strTitle
k = k + 1
End If
Next
Dim i As Integer = p + 1
For Each r As DataRow In ds.Tables(0).Rows
If includeTotals OrElse (Not r.Item(2).ToString().Trim().ToUpper().StartsWith("TOTAL") AndAlso _
Not r.Item(2).ToString().Trim().ToUpper().StartsWith("SUBTOTAL") AndAlso _
Not r.Item(2).ToString().Trim().ToUpper().StartsWith("TOTAL") AndAlso _
Not r.Item(2).ToString().Trim().ToUpper().StartsWith("SUBTOTAL")) Then
k = 0
For j As Integer = 0 To ds.Tables(0).Columns.Count - 1
If Not skip.Contains(j) Then
If r.Item(j) Is DBNull.Value Then
worksheet.Cells(i, k + 1).Value = ""
Else
If k = 0 Then
worksheet.Cells(i, k + 1).Style.Numberformat.Format = "#"
worksheet.Cells(i, k + 1).Value = r.Item(j).ToString()
Else
worksheet.Cells(i, k + 1).Value = r.Item(j)
End If
End If
// Checking if it is first col last row
If r.Item(j).ToString().Contains("TOTAL") Then
totalRow = i
End If
If r.Item(j).GetType().Name = "Decimal" Then
If roundUp Then
If useParens Then
worksheet.Cells(i, k + 1).StyleID = 2
Else
worksheet.Cells(i, k + 1).StyleID = 2 '4
End If
Else
If useParens Then
worksheet.Cells(i, k + 1).StyleID = 1
Else
worksheet.Cells(i, k + 1).StyleID = 1 '3
End If
End If
End If
k = k + 1
End If
Next
i = i + 1
End If
Next
End If
If String.IsNullOrEmpty(HttpContext.Current.Request.QueryString("oversight")) Then 'This is Summary Level
Dim worksheet2 As ExcelWorksheet = pkg.Workbook.Worksheets.Add("Chart - CY Consumable")
worksheet2.DefaultColWidth = 15
// showing the criteria
p = 1
If includeCriteria Then
Try
Dim reportTitle As String = String.Empty
reportTitle = "Central/Regional Oversight Programs"
Dim sb As StringBuilder = New StringBuilder()
sb.Append(reportTitle)
worksheet2.Cells(p, 1).Value = sb.ToString()
sb.Length = 0
p = p + 1
sb.Append("Budget Fiscal Year : ")
sb.Append(HttpContext.Current.Session("bfy"))
worksheet2.Cells(p, 1).Value = sb.ToString()
sb.Length = 0
p = p + 1
sb.Append("Currently viewing transactions from inception through ")
Dim fm As Integer = CInt(HttpContext.Current.Session("fm"))
If fm < 4 Then
sb.Append(MonthName(fm + 9))
sb.Append(" ")
sb.Append(CInt(HttpContext.Current.Session("fy")) - 1)
Else
sb.Append(MonthName(fm - 3))
sb.Append(" ")
sb.Append(HttpContext.Current.Session("fy"))
End If
worksheet2.Cells(p, 1).Value = sb.ToString()
sb.Length = 0
p = p + 1
If String.IsNullOrEmpty(HttpContext.Current.Request.QueryString("division")) Then
sb.Append("Fund Center(s) : ALL")
worksheet2.Cells(p, 1).Value = sb.ToString()
sb.Length = 0
p = p + 1
Else
sb.Append("Fund Center(s) : ")
sb.Append(HttpContext.Current.Request.QueryString("division"))
worksheet2.Cells(p, 1).Value = sb.ToString()
sb.Length = 0
p = p + 1
End If
If String.IsNullOrEmpty(HttpContext.Current.Request.QueryString("fa5")) Then
sb.Append("Func Area 5 : ALL")
worksheet2.Cells(p, 1).Value = sb.ToString()
sb.Length = 0
p = p + 1
Else
sb.Append("Func Area 5 : ")
sb.Append(HttpContext.Current.Request.QueryString("fa5"))
worksheet2.Cells(p, 1).Value = sb.ToString()
sb.Length = 0
p = p + 1
End If
If Not String.IsNullOrEmpty(HttpContext.Current.Request.QueryString("oversight")) Then
sb.Append("Oversight Program - ")
sb.Append(HttpContext.Current.Request.QueryString("oversight"))
worksheet2.Cells(p, 1).Value = sb.ToString()
sb.Length = 0
p = p + 1
End If
sb.Append("FBMS data as of ")
sb.Append(HttpContext.Current.Application("lastUpdated_BIA"))
sb.Append(" at close of business.")
worksheet2.Cells(p, 1).Value = sb.ToString()
sb.Length = 0
p = p + 1
worksheet2.Cells(p, 1).Value = ""
p = p + 1
Catch ex As Exception
For r As Integer = 1 To p - 1
worksheet2.DeleteRow(1, True)
Next
p = 1
End Try
End If
//create chart in new tab
Dim consumableChart As OfficeOpenXml.Drawing.Chart.ExcelPieChart = worksheet2.Drawings.AddChart("ConsumableChart", OfficeOpenXml.Drawing.Chart.eChartType.Pie)
Dim r1, r2 As ExcelRange
// setting the value to check the last row
Dim startColumn As String = "A"
Dim endColumn As String = "B"
Dim startIndex As Integer = 8 // Index where to start
Dim endIndex As Integer = totalRow - 1 'this is determined based on the TOTAL Line from above code
// checking and setting the values and label of pie chart
r1 = worksheet.Cells(String.Concat(startColumn, startIndex.ToString(), ":", startColumn, endIndex))
r2 = worksheet.Cells(String.Concat(endColumn, startIndex.ToString(), ":", endColumn, endIndex))
consumableChart.Series.Add(r2, r1)
consumableChart.Style = OfficeOpenXml.Drawing.Chart.eChartStyle.Style2
consumableChart.Title.Text = "FY 2018 Consumable by Regional & Central Oversight Programs"
consumableChart.Legend.Remove()
consumableChart.SetPosition(5, 5, 5, 5)
consumableChart.SetSize(1040, 880)
consumableChart.DataLabel.ShowLeaderLines = True
consumableChart.DataLabel.ShowCategory = True
consumableChart.DataLabel.ShowPercent = True

VBA Cutting string after last word less than 80 characters total length

I am:
using the Excel Clean function to strip all formatting off any text, and
then I want to break the resulting long string into separate rows of 80 characters or less.
the only delimiter remaining after the clean is a white space.
The code below does this like a champ but it is brutal;
Code
Sub TrimTo75()
myRow = 4
Range("C" & myRow).Select
myString = ActiveCell.Value
While myString <> ""
While Len(myString) > 75
mySubString = Left(myString, 75)
ActiveCell.Value = mySubString
myString = Right(myString, Len(myString) - 75)
myRow = myRow + 1
Range("C" & myRow).Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlDown
If Len(myString) < 75 Then
ActiveCell.Value = myString
End If
Wend
myRow = myRow + 1
Range("C" & myRow).Select
myString = ActiveCell.Value
Wend
End Sub
Try this ..
Sub TrimTo75()
myRow = 4
Range("C" & myRow).Select
myString = ActiveCell.Value
Dim x As Integer
While myString <> ""
While Len(myString) >= 75
x = 75
While Not Mid(myString, x, 1) = " "
x = x - 1
Wend
MsgBox x
'mySubString = Left(myString, 75)
mySubString = Left(myString, x)
ActiveCell.Value = mySubString
'myString = Right(myString, Len(myString) - 75)
myString = Mid(myString, x + 1)
myRow = myRow + 1
Range("C" & myRow).Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlDown
If Len(myString) < 75 Then
ActiveCell.Value = myString
End If
Wend
myRow = myRow + 1
Range("C" & myRow).Select
myString = ActiveCell.Value
Wend
End Sub
This code uses a Regex and a variant array for quick parsing
It takes a range from C4:Cx and places the chunks in D4 down
Sub QuickStrip()
Dim Regex As Object
Dim RegexMC As Object
Dim RegexM As Object
Dim lngCnt As Long
Dim lngOut As Long
X = Range([c4], Cells(Rows.Count, "C").End(xlUp))
Application.ScreenUpdating = False
Set Regex = CreateObject("vbscript.regexp")
With Regex
.Pattern = "[\w\s]{1,79}([^\w]|$)"
.Global = True
For lngCnt = 1 To UBound(X)
If .test(X(lngCnt, 1)) Then
Set RegexMC = .Execute(X(lngCnt, 1))
For Each RegexM In RegexMC
[d4].Offset(lngOut, 0) = RegexM
lngOut = lngOut + 1
Next
End If
Next
End With
Application.ScreenUpdating = True
End Sub
If Len(rngCellsB_Title) > 90 Then
x = 90
While Not Mid(rngCellsB_Title, x, 1) = " "
x = x - 1
Wend
strFirstPart = Left(rngCellsB_Title, x)
strSecondPart = Right(rngCellsB_Title, (Len(rngCellsB_Title) - x))
blnSplit = True
End If
If blnSplit Then
strMessageTemp = strFirstPart & strSecondPart & Chr(13)
blnSplit = False
Else
strMessageTemp = rngCellsB_Title & Chr(13)
End If
Try this, it simply splits the string before a known point using the space as a demiliter. I used a simple boolean to test for before processing either the whole string, or 2 parts of it.

Resources