NumberFormat seems to be a straightforward function but I can't get it to work is a rather simple case. In the code below VBA tells me "Type Mismatch".
For j = 1 To last_column + 1
For f = 2 To total_tranches + 1
If allocation(f - 1, j - 1) = Empty And j <> 1 Then
Allo1.Cells(AlShares.Row - 1 + f, j + 1) = 0
Else
Allo1.Cells(AlShares.Row - 1 + f, j + 1) = allocation(f - 1, j - 1)
If j = 1 Then Allo1.Cells(AlShares.Row - 1 + f, j + 1).IndentLevel = 1
If j = 2 Then Allo1.Cells(AlShares.Row - 1 + f, j + 1).NumberFormat = "_($*#,##0_);_($*(#,##0);_($*" - "??_);_(#_)"
End If
Next f
Next j
And if I replace specific formatting with "Accounting" it just does not work. Please help!
You are asking VBA to subtract 2 strings "...($*" - "??_.." so that is the type mismatch.
Related
I have a for loop that takes a user's input and one of the keys in my dictionary and passes them to a Damerau-Levenshtein function and based on the distance, overwrites the user's input with the dictionary key (The for loop is to cycle through each dictionary key). This works fine enough for strings larger than three characters, but if the string is three or fewer characters the algorithm returns with the wrong key. Here's the for loop:
1950 For j = 0 To dict.Count - 1
1960 distance = DamerauLevenshtein(SplitStr(i), dict.Keys(j))
1970 'MsgBox dict.Keys(j) & vbCrLf & distance ' used for debugging
1980 If distance < 4 Then
1990 If distance < leastDist Then
2000 leastDist = distance
2010 SplitStr(i) = dict.Keys(j)
2020 End If
2030 End If
2040 Next
2050 MsgBox "The distance is: " & leastDist & vbCrLf & "The entered text was " & tempStr & vbCrLf & "The replaced word is " & SplitStr(i)
SplitStr(i) holds the user's input, which comes from a split function. I arbitrarily picked 4 for a good distance
I stole the algorithm from a bytes.com forum post. Algorithm below:
Function DamerauLevenshtein(str1, str2, Optional intSize = 256)
Dim intTotalLen, arrDistance, intLen1, intLen2, i, j, arrStr1, arrStr2, arrDA, intMini
Dim intDB, intI1, intJ1, intD
str1 = UCase(str1)
str2 = UCase(str2)
intLen1 = Len(str1)
intLen2 = Len(str2)
intTotalLen = intLen1 + intLen2
ReDim arrStr1(intLen1)
ReDim arrStr2(intLen2)
ReDim arrDA(intSize)
ReDim arrDistance(intLen1 + 2, intLen2 + 2)
arrDistance(0, 0) = intTotalLen
For i = 0 To intSize - 1
arrDA(i) = 0
Next
For i = 0 To intLen1
arrDistance(i + 1, 1) = i
arrDistance(i + 1, 0) = intTotalLen
Next
For i = 1 To intLen1
arrStr1(i - 1) = Asc(Mid(str1, i, 1))
Next
For j = 0 To intLen2
arrDistance(1, j + 1) = j
arrDistance(0, j + 1) = intTotalLen
Next
For j = 1 To intLen2
arrStr2(j - 1) = Asc(Mid(str2, j, 1))
Next
For i = 1 To intLen1
intDB = 0
For j = 1 To intLen2
intI1 = arrDA(arrStr2(j - 1))
intJ1 = intDB
If arrStr1(i - 1) = arrStr2(j - 1) Then
intD = 0
Else
intD = 1
End If
If intD = 0 Then intDB = j
intMini = arrDistance(i, j) + intD
If intMini > arrDistance(i + 1, j) + 1 Then intMini = arrDistance(i + 1, j) + 1
If intMini > arrDistance(i, j + 1) + 1 Then intMini = arrDistance(i, j + 1) + 1
If intMini > arrDistance(intI1, intJ1) + i - intI1 + j - intJ1 - 1 Then intMini = arrDistance(intI1, intJ1) + i - intI1 + j - intJ1 - 1
arrDistance(i + 1, j + 1) = intMini
Next
arrDA(arrStr1(i - 1)) = i
Next
DamerauLevenshtein = arrDistance(intLen1 + 1, intLen2 + 1)
End Function
If I type in "Cire" the algorithm correctly returns "CORE".
"Raman" returns "REMAN"
"Cosnigned" returns "CONSIGNED
However, "Now" should return "New" but returns "OCM".
"New" also returns "OCM" (so distance should be 0, but is 2.)
"FP" should be "FP" but returns "OCM", distance is 2
"DPF" Should be "DPF" but returns "OCM", distance is 2
I just learned about the algorithm, so I'm sure I'm missing something important, but I just can't see it. Thoughts?
I figured it out. After much searching I found a post saying that an edit distance is commonly 2. (They didn't specify any merits on why 2 is common)
I switched my if statement to 2 from 4 and now all of the problem terms are being corrected as they should be.
I am working in this project where I have to compare the value of an array with itself so I have used 2 2D arrays having the same size and values where I used one for comparing while making changes to the other the problem is that when I make changes to one the other also changes.
is there any way I can assign the value of any 2D arrays without having them changing together.
what I have used is the simple vb.net assignment:
x=y and it works fine only for that one issue.
I haven't completed the code yet that's what I have for now.
xgame = game
For i As Integer = 0 To n - 1
For j As Integer = 0 To n - 1
If (j = 0 And i = 0) Then
If xgame(i, j + 1) = "1" Then
count = count + 1
End If
If xgame(i + 1, j) = "1" Then
count = count + 1
End If
If xgame(i + 1, j + 1) = "1" Then
count = count + 1
End If
If count <= 1 Then
game(i, j) = "-"
End If
ElseIf (i = 0 And ((j > 0) Or (j < n - 1))) Then
count = 0
If xgame(i, j - 1) = "1" Then
count = count + 1
End If
If xgame(i, j + 1) = "1" Then
count = count + 1
End If
If xgame(i + 1, j - 1) = "1" Then
count = count + 1
End If
If xgame(i + 1, j) = "1" Then
count = count + 1
End If
If xgame(i + 1, j + 1) = "1" Then
count = count + 1
End If
If (count < 2 Or count > 3) Then
game(i, j) = "-"
ElseIf (count = 3) Then
game(i, j) = "1"
End If
ElseIf (i = 0 And j = n - 1) Then
End If
Next
Next
For j = 1 To 8
Sheet5.Cells(j + 1, 2) = 480
Next
t = 0
c = 0
For j = LBound(arrayTime) + 1 To UBound(arrayTime)
MsgBox "j " & j
'MsgBox (t)
numMins = Sheet5.Cells((j + 1) - (8 * c), 2) - arrayTime(j)
If numMins < 0 Then
t = t + 1
ReDim Preserve arrayTime(numrows - 1 + t)
arrayTime(numrows - 1 + t) = arrayTime(j)
MsgBox (arrayTime(numrows - 1 + t))
Else
Sheet5.Cells((j + 1) - (8 * c), 2) = numMins
End If
If j = 8 * (c + 1) Then
c = c + 1
End If
MsgBox ("end " & t)
Next
Im trying to add an value to arrayTime if the condition is true. I successfully added it but the for loop will not re-dimension to loop through the added element. The array originally contains 12 elements then I add a 13th but the loop does to recognize the 13th element and only loops 12 times. Any suggestions on how to get the for loop to loop 13 times?
Add a loop counter, say i, and set it to LBound(arrayTime) + 1 then use a Do Until (i = UBound(arrayTime)). This forces VBA to recalculate the upper bound before each loop.
In excel, I have column 1 with tickers, and column 2 with numbers, like this:
A B
1 AAA 10
2 AAA 12
3 AAA 14
4 BBB 9
5 BBB 10
6 BBB 11
I need a piece of code to calculate average BY TICKER, which means that in this case I would have AAA average : 12 and BBB average = 10, etc etc etc. Up to now all i got is this code which tries to calculate the sums, I will do the divisions later, but something's wrong:
For row = 2 to 6
Ticker = Cells(row - 1, 1)
If Cells(row, 1) = Cells(row - 1, 1) Then
sum = sum + Cells(row, 2)
Else
Cells(row, 6) = sum
sum = 0
row = row + 1
Next
I get an error saying "For is missing"
Maybe something like this in C1.
=IF(A1<>A2,AVERAGEIF(A:A,A1,B:B),"")
In your code:
sum ignored the first AAA
missed the End If
incremented row twice, once by row = row+1 and then by next
and some other not used variables
Try this:
Prev = "***"
For row = 1 to 6
If Cells(row, 1) = prev Then
sum = sum + Cells(row, 2)
Else
Cells(row, 6) = sum
sum = 0
End If
prev = Cells(row,1)
Next
To extend the answer from Jeeped and do it with a list which is not ordered, you also could do it like this:
C1: =A1
C2: =IF(LEN(C1),IFERROR(INDEX(A:A,MATCH(1,(COUNTIF(C$1:C1,A$1:A$1000)=0)*(A$1:A$1000<>""),0)),""),"")}
C3....Cn: copy down from C2
D1: =IF(LEN(C1),AVERAGEIF(A:A,C1,B:B),"")
D2...Dn: copy down from D1
C2 is an array formula and needs to be confirmed with Ctrl+Shift+Enter
to do it via VBA (should be faster than my formula for really big tables) you can use something like that: (put this in a "Module" in the VBA-Window, the same like your recorded macros ar written)
Option Explicit
Public Function getAllAvg(rng As Range) As Variant
Set rng = Intersect(rng.Parent.UsedRange, rng)
Dim varInput As Variant
varInput = rng.Value
Dim varOutput() As Variant
ReDim varOutput(1 To UBound(varInput), 1 To 2)
varOutput(1, 1) = ""
Dim i As Long, j As Long
For i = 1 To UBound(varInput)
If Len(varInput(i, 1)) Then
j = 1
While Len(varOutput(j, 1)) And (varOutput(j, 1) <> varInput(i, 1)) And (j < UBound(varOutput))
j = j + 1
Wend
If Len(varOutput(j, 1)) = 0 Then
varOutput(j, 1) = varInput(i, 1)
varOutput(j, 2) = Application.AverageIf(rng.Columns(1), varOutput(j, 1), rng.Columns(2))
varOutput(j + 1, 1) = ""
End If
End If
Next
While Len(varOutput(j, 1)) And (j < UBound(varOutput))
j = j + 1
Wend
If Len(varOutput(j, 1)) = 0 Then
For i = j To UBound(varOutput)
varOutput(i, 1) = ""
varOutput(i, 2) = ""
Next
End If
getAllAvg = varOutput
End Function
then select a range like C2:D12 and enter:
=getAllAvg(A:B)
and confirm with Ctrl+Shift+Enter. it will directly output the whole list (and recalculate if needed)
EDIT:
If your list is always in a sorted order, you also could use this code:
Option Explicit
Public Function getAllAvgSorted(rng As Range) As Variant
Set rng = Intersect(rng.Parent.UsedRange, rng)
Dim varInput As Variant
varInput = rng.Value
Dim varOutput() As Variant
ReDim varOutput(1 To UBound(varInput), 1 To 2)
varOutput(1, 1) = ""
Dim i As Long, j As Long
j = 1
For i = 1 To UBound(varInput)
If Len(varInput(i, 1)) Then
If varOutput(j, 1) <> varInput(i, 1) Then
If Len(varOutput(j, 1)) Then j = j + 1
varOutput(j, 1) = varInput(i, 1)
varOutput(j, 2) = Application.AverageIf(rng.Columns(1), varOutput(j, 1), rng.Columns(2))
End If
End If
Next
While j < UBound(varOutput)
j = j + 1
varOutput(j, 1) = ""
varOutput(j, 2) = ""
Wend
getAllAvgSorted = varOutput
End Function
When I run the code below I get the annoying 1004 error.
Sub TEST_MACRO()
Dim shSource As Worksheet
Dim shDest As Worksheet
Dim DateRange As Range
Dim i As Integer, nullcounter As Integer, nullcounterov As Integer, tablelength As Integer, tablelengthov As Integer, DateRangeSize As Integer
Dim q As Integer
Set shSource = ThisWorkbook.Sheets("Sheet1")
Set shDest = ThisWorkbook.Sheets("Sheet2")
Set DateRange = shSource.Application.InputBox("Select date", Type:=8)
DateRangeSize = DateRange.Rows.Count
nullcounter = 0
nullcounterov = 0
tablelength = 3
tablelengthov = 3
For q = 0 To DateRangeSize - 1
shDest.Range("C4:I17").ClearContents
'THIS IS THE CODE FOR ABC
For i = 0 To 3
If IsEmpty(shSource.Cells(DateRange.Row + q, 2 + i)) = True Or shSource.Cells(DateRange.Row + q, 2 + i) = 0 Then
nullcounter = nullcounter + 1
Else
shDest.Cells(4 + i - nullcounter, 4) = shSource.Cells(DateRange.Row + q, 2 + i)
shDest.Cells(4 + i - nullcounter, 5) = shSource.Cells(DateRange.Row + q, 6 + i)
shDest.Cells(4 + i - nullcounter, 3) = shSource.Cells(1, 2 + i)
tablelength = tablelength + 1
End If
Next
'THIS IS THE CODE FOR XYZ
For i = 0 To 6
If IsEmpty(shSource.Cells(DateRange.Row + q, 10 + i)) = True Or shSource.Cells(DateRange.Row + q, 10 + i) = 0 Then
nullcounterov = nullcounterov + 1
Else
shDest.Cells(4 + i - nullcounterov, 8) = shSource.Cells(DateRange.Row + q, 10 + i)
shDest.Cells(4 + i - nullcounterov, 9) = shSource.Cells(DateRange.Row + q, 17 + i)
shDest.Cells(4 + i - nullcounterov, 7) = shSource.Cells(1, 10 + i)
tablelengthov = tablelengthov + 1
End If
Next
Next
End Sub
The excel sheet I run this on looks like this:
http://i.imgur.com/V7tWTKq.png
The code works for ABC but it doesn't for XYZ. I'm guessing the 0 value cells are messing it up but I don't understand why.
The goal of the code is:
User is prompted to select a range of size DateRangeSize.
For each row in the range the code copies the values of ABC, ABC-D, XYZ and XYZ-D if they aren't 0 and writes them to sheet 2.
If the number of rows in the range is 1, the code works fine. But if the number of rows is greater than 1, I get the 1004 error where this part of the code is highlight:
shDest.Cells(4 + i - nullcounterov, 8) = shSource.Cells(DateRange.Row + q, 10 + i)
I appreciate the help.
EDIT: I just want to add that the code ALWAYS works for ABC. If the number of rows is 2 then the ABC values for the second row are printed in sheet2 but the code breaks when it attempts to do the same for XYZ.
EDIT 2: I added 0 values to the ABC portion but the code still works for ABC! This is so frustrating.
I figured it out. I defined
nullcounter = 0
nullcounterov = 0
tablelength = 3
tablelengthov = 3
Outside of the loop so they kept on increasing.
shDest.Cells(4 + i - nullcounterov, 8) = shSource.Cells(DateRange.Row + q, 10 + i)
Eventually 4 + i << nullcounterov and excel tried to write to a cell that didn't exist.
The fixed code:
Sub TEST_MACRO()
Dim shSource As Worksheet
Dim shDest As Worksheet
Dim DateRange As Range
Dim i As Integer, nullcounter As Integer, nullcounterov As Integer, tablelength As Integer, tablelengthov As Integer, DateRangeSize As Integer
Dim q As Integer
Set shSource = ThisWorkbook.Sheets("Sheet1")
Set shDest = ThisWorkbook.Sheets("Sheet2")
Set DateRange = shSource.Application.InputBox("Select date", Type:=8)
DateRangeSize = DateRange.Rows.Count
For q = 0 To DateRangeSize - 1
nullcounter = 0
nullcounterov = 0
tablelength = 3
tablelengthov = 3
shDest.Range("C4:I17").ClearContents
'THIS IS THE CODE FOR ABC
For i = 0 To 3
If IsEmpty(shSource.Cells(DateRange.Row + q, 2 + i)) = True Or shSource.Cells(DateRange.Row + q, 2 + i) = 0 Then
nullcounter = nullcounter + 1
Else
shDest.Cells(4 + i - nullcounter, 4) = shSource.Cells(DateRange.Row + q, 2 + i)
shDest.Cells(4 + i - nullcounter, 5) = shSource.Cells(DateRange.Row + q, 6 + i)
shDest.Cells(4 + i - nullcounter, 3) = shSource.Cells(1, 2 + i)
tablelength = tablelength + 1
End If
Next
'THIS IS THE CODE FOR XYZ
For i = 0 To 6
If IsEmpty(shSource.Cells(DateRange.Row + q, 10 + i)) = True Or shSource.Cells(DateRange.Row + q, 10 + i) = 0 Then
nullcounterov = nullcounterov + 1
Else
shDest.Cells(4 + i - nullcounterov, 8) = shSource.Cells(DateRange.Row + q, 10 + i)
shDest.Cells(4 + i - nullcounterov, 9) = shSource.Cells(DateRange.Row + q, 17 + i)
shDest.Cells(4 + i - nullcounterov, 7) = shSource.Cells(1, 10 + i)
tablelengthov = tablelengthov + 1
End If
Next
Next
End Sub