I have to make a application to load images in excel vba, encrypt that image and save it in cells. My problem is the limit of characters in cell ( 32.767 characters ) and my encrypted string is like 800k characters.
I make a function to make a array of string with custom string character length to save in a row but when i save in cells i recive this error:
Public Function SplitString(ByVal TheString As String, ByVal StringLen As Integer) As String()
Dim ArrCount As Integer 'as it is declared locally, it will automatically reset to 0 when this is called again
Dim I As Long 'we are going to use it.. so declare it (with local scope to avoid breaking other code)
Dim TempArray() As String
ReDim TempArray((Len(TheString) - 1) \ StringLen)
For I = 1 To Len(TheString) Step StringLen
TempArray(ArrCount) = Mid$(TheString, I, StringLen)
ArrCount = ArrCount + 1
Next
SplitString = TempArray 'actually return the value
End Function
Dim StringArray As Variant
StringArray = SplitString(EncodeFile(.SelectedItems(1)), 30000)
Dim ind As Integer
ind = 2
For index = 1 To UBound(StringArray)
Sheet5.Cells(55, ind).value = StringArray(index)
ind = ind + 1
Next index
I solve this problem by adding a delay in for loop but it's not a optimal solution
For index = 1 To UBound(StringArray)
Sheet5.Cells(55, ind).value = StringArray(index)
ind = ind + 1
Application.Wait (Now + TimeValue("00:00:01"))
Next index
And now the question: Can I make this more faster or a better way to solve this problem ?
Dump the array into the cells within one row without the loop.
Sheet5.Cells(55, "A").resize(1, ubound(StringArray) + 1) = StringArray
Related
So I have a data set that is made up of a variety tag numbers - I'm trying to develop a VBA "fucntion" to basically give recommendation on a tag number when inputting a new one. This would be easy but the current list gives gaps within tag numbers (eg) goes 4001 4002 4005 . This bit of code is taking that gap and storing "option" tags which I plan to display to the user (so 4003 and 4004). The problem is that these gaps are encountered more than once eg) 4001 4002 4005 4006 4007 4011 4012 and when it comes to the second gap (4008 4009 4010) it overwrites the existing array - how can I get it take each gap and then begin the array below that?
My code is as follows:
For j = 2 To UBound(strArrayNumber)
If strArrayNumber(j) <> strArrayNumber(j - 1) + 1 Then
Gap = strArrayNumber(j) - strArrayNumber(j - 1)
For b = 1 To Gap
ReDim TagOptions(1 To Gap) As Integer
TagOptions(b) = strArrayNumber(j - 1) + b
sh.Cells(b, 6) = TagOptions(b)
Next b
End If
At the prompting of #JohnSUN here is the bare bones of a solution using Scripting.Dictionary.
The OP desires to manage a data set. To simplify this management I have chosen to create a TagList object. The TagList object allows
Population of the tag list from two arrays
Updating the value associated with a tag item
getting back an array of tags or object
getting an array of the next free tags
testing if a tag exists
This is a bare bones example as it is designed to point the way rather than provide a complete solution. It has some obvious ommisions, i.e. there is no code for what happens if a the request for the next set of free tags uses a tag that is higher then the maximum tag number, there is no error code for what happens if we try to add an existing tag to the TagList etc.
The Class Taglist code compiles without error and shows no significant inospection results after a Rubberduck code inspection
Class TagList
Option Explicit
Private Type State
' Requires a reference to 'Microsoft Scripting Runtime'
TagList As Scripting.Dictionary
End Type
Private s As State
Private Sub Class_Initialize()
Set s.TagList = New Scripting.Dictionary
End Sub
Public Property Get Item(ByVal iptag As Long) As Variant
Item = s.TagList.Item(iptag)
End Property
Public Property Let Item(ByVal iptag As Long, ByVal ipitem As Variant)
s.TagList.Item(iptag) = ipitem
End Property
Public Function Tags() As Variant
Tags = s.TagList.keys
End Function
Public Function Items() As Variant
Items = s.TagList.Items
End Function
Public Sub Add(ByVal ipTags As Variant, Optional ByVal ipItems As Variant)
'ipTags and ipItems should be arrays of equal size
If IsMissing(ipItems) Then
ReDim ipItems(UBound(ipTags) - LBound(Tags) + 1)
End If
If (UBound(ipTags) - LBound(ipTags)) - (UBound(ipItems) - LBound(ipItems)) <> 0 Then
Err.Raise vbObjectError + 512, "Size Error", "Arrays are different sizes"
End If
Dim myItemsIndex As Long
myItemsIndex = LBound(ipItems)
Dim myTag As Variant
For Each myTag In ipTags
s.TagList.Add myTag, CVar(ipItems(myItemsIndex))
myItemsIndex = myItemsIndex + 1
Next
End Sub
Public Function Exists(ByVal iptag As Long) As Boolean
Exists = s.TagList.Exists(iptag)
End Function
Public Function NextFreeTags(ByVal iptag As Long) As Variant
If iptag < 1 Then
Err.Raise vbObjectError + 512, "Negative Tag", "Tag numbers must be positive"
End If
Dim myFreeTags As Scripting.Dictionary
Set myFreeTags = New Scripting.Dictionary
Do While s.TagList.Exists(iptag)
iptag = iptag + 1
Loop
Do Until s.TagList.Exists(iptag)
myFreeTags.Add iptag, iptag
iptag = iptag + 1
Loop
NextFreeTags = myFreeTags.keys
End Function
Thus we can now do the following
Dim myTagList as TagList
Set myTagList = New TagList
mytaglist.Add Array(4006, 4001, 4002, 4011, 4005, 4007)
' Note the above is the short form version we could equally say
' myTagList.add Array(4006, 4001, 4002, 4011, 4005, 4007), Array(Obj6, Obj1, Obj11, Obj5, Obj7)
'Oops, we forgot to add tag 4012
myTaglist.add array(4012)
' getting then next free tags
dim myTags as variant
myTags = myTaglist.NextFreeTags(4001)
etc
Let's not calculate the Gap. The parameters of the cycle by B can be any - we will use this. Try this:
Set oCell = sh.Range("F1")
TagOptions = Array()
For j = 2 To UBound(strArrayNumber)
If strArrayNumber(j) <> strArrayNumber(j - 1) + 1 Then
For b = strArrayNumber(j - 1) + 1 To strArrayNumber(j) - 1
uBoundTagOptions = UBound(TagOptions) + 1
ReDim Preserve TagOptions(1 To uBoundTagOptions)
TagOptions(uBoundTagOptions) = b
oCell.Value = b
Set oCell = oCell.Offset(1, 0)
Next b
End If
Next j
Don't forget to specify Option Base 1 at the beginning of the module, otherwise TagOptions = Array() will create an empty array [0..-1] , with LBound = 0, but you want from LBound = 1
UPDATE
By the way, there is one old trick using an auxiliary array. This is used to clear data from duplicates, for sorting and other things. The method is resource-intensive, but very fast. It looks something like this:
Function getGaps(aData As Variant) As Variant
Dim lB As Long, uB As Long, i As Long, lCount As Long
Dim aTemp() As Boolean, aResult() As Long
If IsArray(aData) Then
lB = Application.WorksheetFunction.Min(aData)
uB = Application.WorksheetFunction.Max(aData)
Rem Let's create an auxiliary array of boolean flags. It may be very large, but it won't be long.
ReDim aTemp(lB To uB)
Rem Let's mark in the array those values ??that are in the aData.
Rem In this case, we will skip duplicates, if any, and count the number of unique numbers.
lCount = 0
For i = LBound(aData) To UBound(aData)
If Not aTemp(aData(i)) Then
aTemp(aData(i)) = True
lCount = lCount + 1
End If
Next i
Rem Number of values in gaps:
uB = uB - lB - lCount + 1
If uB > 0 Then ' It may be that there were no gaps in the array
ReDim aResult(1 To uB)
lCount = 0
For i = LBound(aTemp) To UBound(aTemp)
If Not aTemp(i) Then
lCount = lCount + 1
aResult(lCount) = i
End If
Next i
Rem Here it is - the result of the function
getGaps = aResult
Rem The interpreter will destroy this variable immediately after exiting the function,
Rem but will free the memory a little later. This line should help free memory faster
ReDim aTemp(0)
End If
End If
Rem In all other cases, the function will return Empty
End Function
Despite the number of lines, it is very simple and very fast since all the work is done in RAM.
With this function, all the code you showed in your question becomes:
Set oCell = sh.Range("F1")
oCell.EntireColumn.ClearContents ' This is for the case where no gaps are found
TagOptions = getGaps(strArrayNumber)
If IsEmpty(TagOptions) Then
Debug.Print "No gaps in array"
Exit Sub
End If
oCell.Resize(UBound(TagOptions), 1).Value2 = Application.WorksheetFunction.Transpose(TagOptions)
Of course TRANSPOSE () might not work correctly for a very large array. But I hope that you are not so cruel to your users and the list of possible tags does not exceed a hundred or two.
I have a VBA code that's designed to search a CSV String and add Carriage Returns where they should exist. I've split it up into two seperate functions - one to search the string and put the index of where the CRs should go into an array and a second function to actually add the CRs.
The issue I'm running into is that the value in the immediate window/in the watch window for the functions is correct within the function itself, but it assigns the result variable a blank string.
'*****************Import CSV**********************
'Took this straight off the internet because it was reading Jet.com files as one single line
'
Sub ImportCSVFile(filepath As String)
.....
line = SearchString(line, "SALE")
.....
End Sub
'****************Search String***************************
'This is search the string for something - It will then call a function to insert carriage returns
Function SearchString(source As String, target As String) As String
Dim i As Integer
Dim k As Integer
Dim myArray() As Variant
Dim resultString As String
Do
i = i + 1
If Mid(source, i, Len(target)) = target Then
ReDim Preserve myArray(k)
myArray(k) = i
k = k + 1
End If
DoEvents
Loop Until i = Len(source)
resultString = addCarriageReturns(source, myArray) 'resultString here is assigned a blank string
SearchString = resultString
End Function
'***************Add Carraige Returns**************************
'Cycle through the indices held in the array and place carriage returns into the string
Function addCarriageReturns(source As String, myArray As Variant) As String
Dim i As Integer
Dim resultString As String
resultString = source
For i = 0 To UBound(myArray, 1)
resultString = Left(resultString, myArray(i) + i) & Chr(13) & Right(resultString, Len(resultString) - myArray(i) + i)
Next i
addCarraigeReturns = resultString 'The value of addCarriageReturn is correct in the immediate window here
End Function
In the function the value is not blank
...but when it passes it back, it says the value is blank
I'm just curious, why do you want separate functions like this?
Can you just use:
line = Replace(line, "SALE", "SALE" & Chr(13))
Have some problems with my function. In database i could have diffrent numbers. For instance below: ( i know it looks strange )
12 312323.3
013.43.9
3.23.14353.55 WHATEVER 345.193
728937.3
87.3 ojojo 23.434blabla 24.424.7
What i need to do is increase number after LAST DOT so just make + 1.
The problem is its not working when it comes after dot more than one digit then.
here is my current code:
Dim inputValue as String = "34.234234.6.12"
'--Get Last char from string and add 1 to it
Dim lastChar As String = CInt(CStr(inputValue.Last)) + 1
'--Remove last char and add lastChar
Dim nextCombinNummer As String = lastValue.Nummer.Substring(0, lastValue.Nummer.Length - 1) & lastChar
Return nextCombinNummer
I think the problem is lastValue.Last + 1 as it will take only one digit, and also when i remove by substring last digit but only 2 will be removed.
Can you help me out with this? How to always take number after last dot from string and then increase that number by 1 and return new entire number?
EDIT:
I think i am able to get and increase the number but still dont know how to remove and put it at the end:
Think that's ok:
Dim inputValue as String = "34.234234.6.12"
Dim number As String = inputValue .Substring(inputValue .LastIndexOf("."c) + 1)
Dim numberIncreased as integer = CInt(number) + 1
'How to do this correctly? :
Dim nextCombinNummer As String = lastValue.Nummer.Substring(0, lastValue.Nummer.Length - 1) & numberIncreased
An easy solution is to cast as Integer the last part of the string, add one, then recompose your string :
'Original Value
Dim val As String = "123.456.789"
'We take only the last part and add one
Dim nb = Integer.Parse(val.Substring(val.LastIndexOf(".") + 1)) + 1
'We recompose the string
Dim FinalVal As String = val.Substring(0, val.LastIndexOf(".") + 1) & nb.ToString()
I'd use following which uses String.Split, Int32.TryParse and String.Join:
Dim numbers As New List(Of String) From {"12.312323.3", "013.43.9", "3.231435355345.193", "728937.3", "87.323.43424.424.7"}
for i As Int32 = 0 To numbers.Count -1
Dim num = numbers(i)
Dim token = num.Split("."c)
dim lastNum = token.Last() ' or token(token.Length-1)
Dim n As Int32
If int32.TryParse(lastNum, n)
n += 1
token(token.Length-1) = n.ToString()
End If
numbers(i) = string.Join(".", token)
Next
I'm trying to teach myself VBA writing some little things. I'm trying to make something that allows you to select some data and then calculates the mean and variance. My code is as follows :
Sub VarianceCalculator()
Dim k As Integer
Dim SelectedData As Range
Dim SelectedDataArray() As Variant
Dim Var As Double
Dim Mu As Double
On Error Resume Next
Set SelectedData = Application.InputBox("Select a range of data to be
calculated", Default:=Selection.Address, Type:=8)
On Error GoTo 0
SelectedDataArray = Range(SelectedData.Address)
k = UBound(SelectedDataArray)
Call VarianceCalculatorWithArray(SelectedDataArray, k)
MsgBox ("The selected data has variance " & Var & " and has mean " & Mu)
End Sub
Sub VarianceCalculatorWithArray(Data() As Variant, k As Integer)
Dim Var As Double
Dim Mu As Double
Dim j As Integer
Dim i As Integer
ReDim Data(k) As Variant
Mu = 0
Var = 0
For j = 0 To k
Mu = Mu + (Data(j)) / (k + 1)
Next j
For i = 0 To k
Var = Var + ((Data(i) - Mu) ^ (2)) / (k + 1)
Next i
End Sub
I think the error is that somehow the data is not getting transferred into the array but I can't find a solution to this.
Thanks!!
There are two major problems:
(1) If you want to pass the variables Var and Mu from one procedure to another you'll have to declare them as public variables before the first procedure. The alternative is to setup VarianceCalculatorWithArray as a function.
(2) The array Data() is 2D as a range consists of rows and columns. So, if you want to use an element from this array, you'll have to address it as Data(1, 1). Also note, that this range array starts with row 1 and column 1. Therefore your for...next statements should start with 1 and not with 0.
Note, that you can always set a breakpoint in order to check if data is transferred into the array.
I've written a function that returns the minimum values of the 8 numerical values inputted through SSRS.
Problem is there is not always 8 values and when there isn't I receive an error in SSRS. i think this is because I'm feeding the function null values
I don't ever work with VB, is there anyone who can show me a work around?
The code used is below
enter code here
Function minimumReading(reading0 as String
,reading1 as String
,reading2 as String
... 7 as String)
Dim a(7) as String
a(0) = reading0
a(1) = reading1
...
a(7) = reading7
Dim max as string
Dim min as string
max = a(3)
min = a(3)
Dim i as integer
for i = Lbound(a) to Ubound(a)
if a(i) < min Then min = a(i)
next i
minimumReading = min
End Function`
Thanks in advance
Do you need to pass the 8 values as individual arguments? It would be better form (also easier to maintain long run) to create a function that finds the minimum of an array (which might already exist)
If you must have it the way you have setup you can use this
Dim a() As String
ReDim a(0 To 0)
Dim i As Long
If reading0 <> vbNullString Then
a(UBound(a)) = reading0
End If
If reading1 <> vbNullString Then
ReDim Preserve a(LBound(a) To (UBound(a) + 1))
a(UBound(a)) = reading1
End If
If reading2 <> vbNullString Then
ReDim Preserve a(LBound(a) To (UBound(a) + 1))
a(UBound(a)) = reading2
End If
...
Again my suggestion is to restructure your code.