I have been reading on some of the posts that others were having similar issues for comparing text strings in cells.
The results were close but not quite what the goal is so I a confident that I will get the results.
The image attached is just the desired result. Goal: Compare Old SQL (Column B) to New SQL(Column A)/change font color of the difference in Column A (if any).
image attached shows the desired result
Being 20 yrs removed, I am beyond rusty.
I have tried the leverstein (?? sorry forget the author); tried dupeword and a couple others. Just havent found the right code. I am going to keep looking at examples - I am sure someone has figured it out - just not me.
Public Sub AlignStrings()
Dim a() As Byte, b() As Byte, a_$, b_$, i&, j&, d&, u&, l&, x&, y&, f&()
Const GAP = -1
Const PAD = "$"
a = [a3].Text: b = [b3].Text 'column A &B needs to be a range
'[c2:d2].Clear
'[a1:a6].Font.Name = "Calibri"
ReDim f(0 To UBound(b) \ 2 + 1, 0 To UBound(a) \ 2 + 1)
For i = 1 To UBound(f, 1)
For j = 1 To UBound(f, 2)
x = j - 1: y = i - 1
If a(x * 2) = b(y * 2) Then
d = 1 + f(y, x)
u = 0 + f(y, j)
l = 0 + f(i, x)
Else
d = -1 + f(y, x)
u = GAP + f(y, j)
l = GAP + f(i, x)
End If
f(i, j) = Max(d, u, l)
Next
Next
i = UBound(f, 1): j = UBound(f, 2)
On Error Resume Next
Do
x = j - 1: y = i - 1
d = f(y, x)
u = f(y, j)
l = f(i, x)
Select Case True
Case Err
If y < 0 Then GoTo left Else GoTo up
Case d >= u And d >= l Or Mid$(a, j, 1) = Mid$(b, i, 1)
diag:
a_ = Mid$(a, j, 1) & a_
b_ = Mid$(b, i, 1) & b_
i = i - 1: j = j - 1
Case u > l
up:
a_ = PAD & a_
b_ = Mid$(b, i, 1) & b_
i = i - 1
Case l > u
left:
a_ = Mid$(a, j, 1) & a_
b_ = PAD & b_
j = j - 1
End Select
Loop Until i < 1 And j < 1
DecorateStrings a_, b_, [a3], [b3], PAD 'output needs to be in same
columns/range
Related
using excel VBA i have to generate a table of numbers counting anti clock wise with one in the middle and highlight prime numbers in red in the process the following image is an example of the out put i should have .
Thanks to you guys i have used the above code to come up with this code which works perfectly.
Option Explicit
Private Function GetPrime(MaxToCheck As Long) As Collection
Dim c As New Collection, isUnDivided As Boolean, i As Long, v
c.Add Key:="2", Item:=2
For i = 3 To MaxToCheck
isUnDivided = True
For Each v In c
If i Mod v = 0 Then isUnDivided = False: Exit For
Next v
If isUnDivided Then c.Add Key:=CStr(i), Item:=i
Next i
Set GetPrime = c
End Function
Sub prime()
Dim a, c As New Collection, i As Long, j As Long, r As Range, v
With Range("A1").CurrentRegion
a = .Value
Set c = GetPrime(Application.Max(a))
For i = 1 To UBound(a, 1)
For j = 1 To UBound(a, 2)
On Error Resume Next
v = c(CStr(a(i, j)))
If Err.Number = 0 Then
If Not r Is Nothing Then Set r = Union(r, .Cells(i, j)) Else
Set r = .Cells(i, j)
End If
On Error GoTo 0
Next j
Next i
End With
If Not r Is Nothing Then r.Font.Color = vbRed
End Sub
Here is a sample code for you to start with,
Sub primeNum()
Dim i As Long, j As Long, k As Long, x As Long, y As Long, z As Long
Dim l As Long
j = 50
x = 20
y = 20
k = 1
i = 1
Cells(x, y) = 1
Loops:
For z = 1 To 4
If z = 3 Then
k = k + 1
End If
For l = 1 To k
i = i + 1
Select Case (z)
Case "1":
y = y + 1
Cells(x, y) = i
Case "2":
x = x - 1
Cells(x, y) = i
Case "3":
y = y - 1
Cells(x, y) = i
Case "4":
x = x + 1
Cells(x, y) = i
End Select
Next l
Next z
k = k + 1
If i <= j Then
GoTo Loops
End If
End Sub
I leave the part of checking prime numbers for you to google and find,
I have a single box with sides l, w, h (natural numbers). I have to pack this standard box to the BIN under constraints: Longest BIN side <=150, Longest BIN side + 2*(sum of other 2 sides)<=300. Based on Lagrange Multipliers the maximum BIN volume and length of sides under these constraints are 100x50x50=250000. The optimal BIN sides should be close to 100x50x50 and must have maximum volume. Now the below code works, but for a box with small sides it is taking more time. For example, if box sides are 1x1x1, then it calculates all options 150x150x150 under above constraints. If anybody has better idea how to improve this code, please help.
`Sub Macro1()
l = Sheets("list").Range("a" & 2)'45
w = Sheets("list").Range("b" & 2)'20
h = Sheets("list").Range("c" & 2)'30
result = 150 / l
ll = Math.Round(150 / l, 0)
If result <> ll Then
ll = ll + 1
Else
End If
result = 150 / w
lw = Math.Round(150 / w, 0)
If result <> lw Then
lw = lw + 1
Else
End If
result = 150 / h
lh = Math.Round(150 / h, 0)
If result <> lh Then
lh = lh + 1
Else
End If
Dim londis() As Double
Dim shortdis() As Double
Dim options() As Double
ReDim options(lw * ll * lh)
ReDim longdis(lw * ll * lh)
ReDim shortdis(lw * ll * lh)
k = 6
s = 0
`
For i = 0 To lh
For j = 0 To lw
For n = 0 To ll
summa = i * h + j * w + n * l
If summa <= 150 Then
'Sheets("list").Range("a" & k) = summa
s = s + 1
options(s) = summa
'longdis(s) = 100 - summa
'shortdis(s) = 50 - summa
If summa > 100 Then
longdis(s) = 100 - summa
Else
longdis(s) = summa - 100
End If
If summa <= 50 Then
shortdis(s) = summa - 50
Else
shortdis(s) = 50 - summa
End If
k = k + 1
Else
GoTo 1
End If
Next n
1:
Next j
Next i
For i = 1 To s - 1
For j = i + 1 To s
If shortdis(i) < shortdis(j) Then
pTemp1 = options(i)
pTemp2 = longdis(i)
pTemp3 = shortdis(i)
options(i) = options(j)
shortdis(i) = shortdis(j)
longdis(i) = longdis(j)
options(j) = pTemp1
longdis(j) = pTemp2
shortdis(j) = pTemp3
Else
End If
Next j
Next i
t = 1
maxVol = 0
pT = 0
pL = 0
prodVol = l * w * h
maxPosUnit = Int(250000 / prodVol)
maxPosVol = maxPosUnit * prodVol
Do While t < s - 2
longside = 300 - 2 * (options(t) + options(t + 1))
For i = 1 To s
If options(i) <= longside Then
vol = options(i) * options(t) * options(t + 1)
If vol > maxVol Then
maxVol = vol
pT = t
pL = i
Else
End If
Else
End If
If options(i) = longside Then
Exit Do
End If
Next i
t = t + 1
Loop
Sheets("list").Range("d" & 2) = prodVol
Sheets("list").Range("e" & 2) = maxPosUnit
'Sheets("list").Range("f" & 2) = 250000 - maxPosVol
Sheets("list").Range("a" & 3) = options(pT)
Sheets("list").Range("b" & 3) = options(pT + 1)
Sheets("list").Range("c" & 3) = options(pL)
boxVol = options(pT) * options(pT + 1) * options(pL)
Sheets("list").Range("d" & 3) = boxVol
Sheets("list").Range("e" & 3) = Int(boxVol / prodVol)
Sheets("list").Range("f" & 3) = boxVol - Int(boxVol / prodVol) * prodVol
End Sub
Let's say I have a list of numbers
Column A
1
2
3
4
5
6
7
and I want to move these numbers to B, C, D. evenly like
Column B: 1,2,3, Column C: 4,5, Column D: 6,7
The list of numbers always changes.
Sub Macro1()
'
' Macro1 Macro
'
'
k = 0
r = Range("A1").End(xlDown).Row
For i = 1 To r
j = 2
If k = 0 Then
k = 1
End If
If i <= (r / 3) Then
Cells(k, j).Value = Cells(i, 1)
k = k + 1
If (i + 1) > (r / 3) Then
k = 0
End If
End If
j = 3
If i > r / 3 And i <= 2 * (r / 3) Then
Cells(k, j).Value = Cells(i, 1)
k = k + 1
If (i + 1) > 2 * (r / 3) Then
k = 0
End If
End If
j = 4
If i > 2 * (r / 3) Then
Cells(k, j).Value = Cells(i, 1)
k = k + 1
End If
Next i
End Sub
I want this code to search the column name called((attribute value1,attribute value2..N)
If that column contains fraction values, it should convert it to decimal. I'm using this macros(VBA).
The code is working but it is converting only one column(attribute value1).
It will take more time because I have multiple columns(attribute value2...N) that have fraction values.
Please help me out I am struck here.
Sub deci()
Dim LR As Long
Dim Dash As Long
Dim Whole As Double
Dim lngDataColumn As Long
Dim pi
lngDataColumn = 4
Sheets("Sheet3").Select
LR = Cells(Rows.Count, lngDataColumn).End(xlUp).row
For r = 2 To LR
s = Cells(r, lngDataColumn)
arr = Split(s, ",")
For i = LBound(arr) To UBound(arr)
Whole = 0
P = InStr(arr(i), " IN")
If P > 0 Then
Worksheet = (Left((arr(i)), P - 1))
Else
Worksheet = arr(i)
End If
Dash = InStr(Worksheet, "-")
If Dash > 0 Then
Whole = Frac(Left(Worksheet, Dash - 1))
Worksheet = Mid(Worksheet, Dash + 1)
End If
af = Right(arr(i), Len(arr(i)) - P + 1)
evfrac = Whole + Left(CStr(Evaluate(Worksheet)), 5)
' evfrac = Whole + Format(Evaluate(frac), "0.###")
ss = ss & evfrac & af & ", "
Next i
Cells(r, lngDataColumn) = Left(ss, Len(ss) - 2)
ss = ""
Next r
End Sub
Function Frac(ByVal X As String) As Double
Dim P As Integer, N As Double, Num As Double, Den As Double
X = Trim$(X)
P = InStr(X, "/")
If P = 0 Then
N = Val(X)
Else
Den = Val(Mid$(X, P + 1))
If Den = 0 Then Err.Raise 11 ' Divide by zero
X = Trim$(Left$(X, P - 1))
P = InStr(X, " ")
If P = 0 Then
Num = Val(X)
Else
Num = Val(Mid$(X, P + 1))
N = Val(Left$(X, P - 1))
End If
End If
If Den <> 0 Then
N = N + Num / Den
End If
Frac = N
End Function
The reason it's only doing one column is because that's exactly what your telling it to do with this section of the code:
lngDataColumn = 4
Sheets("Sheet3").Select
LR = Cells(Rows.Count, lngDataColumn).End(xlUp).row
Because your setting lngDataColumn as a fixed figure, your code is only executed on column 4. If you want to do more columns as a loop, you need to increment this value in the same maner you are incrementing r in your for loop.
For example:
lngDataColumn = 10
Sheets("Sheet3").Select
For 4 To lngDataColumn
LR = Cells(Rows.Count, lngDataColumn).End(xlUp).row
'Rest of code
Next lngDataColumn
How do i decode %C3%B8 in VBA? it is the danish letter ΓΈ -
It is encoded in UTF-8. I have tried to decode it in vba for use in a excel sppreadsheet with the following function:
Function DecodeUTF8(s)
Dim i
Dim c
Dim n
i = 1
Do While i <= Len(s)
c = Asc(Mid(s, i, 1))
If c And &H80 Then
n = 1
Do While i + n < Len(s)
If (Asc(Mid(s, i + n, 1)) And &HC0) <> &H80 Then
Exit Do
End If
n = n + 1
Loop
If n = 2 And ((c And &HE0) = &HC0) Then
c = Asc(Mid(s, i + 1, 1)) + &H40 * (c And &H1)
Else
c = 191
End If
s = Left(s, i - 1) + Chr(c) + Mid(s, i + n)
End If
i = i + 1
Loop
DecodeUTF8 = s
End Function
You have to use UrlDecode or HmlDecode methods
see here for more information
http://msdn.microsoft.com/en-us/library/system.web.httputility.urldecode.aspx
or here
http://msdn.microsoft.com/en-us/library/7c5fyk1k.aspx