1 Attachment(s)
VBA To Compare Multiple Cells
Hi everyone,
I am new to VBA programming in Excel. Can someone please help me create a VBA program. I have searched in multiple websites but i couldn't find anything. I already made the program to compare 2 columns based of fixed rows and cells.
What i'm trying to do now is the following:
- The user will input the number of columns and select it's cell location
- Then the macro will compare the cell values of every columns at the same time, row by row. For example: Cell 1, Column 1 vs Cell 1, Column 2 and Cell 1, Column 1 vs Cell 1, Column 3 (if the number of selected columns is 3)
- If the compare fails the script will shift the row of the column where the compare failed down.
Here's what i made so far, the problem is the columns comparision is made only by 2 columns at a time. I've also attached my workbook.
Attachment 1181
Code:
Option Base 1
Sub userDef()
Dim cNum As Long
Dim stColArray(), lstColArray() As Variant
Dim cRowArray(), cColArray() As Variant
Dim cSel, rSel As Range
Dim rw, col, j, mvSt1, mvEnd1, mvSt2, mvEnd2 As Integer
j = 1
cNum = Application.InputBox("Number of columns:")
ReDim rStArray(cNum)
ReDim stColArray(cNum)
ReDim lstColArray(cNum)
ReDim cRowArray(cNum)
ReDim cColArray(cNum)
For c = 1 To cNum
Set rSel = Application.InputBox("Select " & c & " table(s)", Type:=8)
Set cSel = Application.InputBox("Select " & c & " cell(s) of " & c & " table", Type:=8)
If rSel Is Nothing Then
MsgBox "No cell selected"
Exit Sub
Else
stColArray(j) = rSel.Column
lstColArray(j) = rSel.Columns(rSel.Columns.Count).Column
cRowArray(j) = cSel.Row
cColArray(j) = cSel.Column
j = j + 1
End If
Next c
j = 1
x = 1
y = 2
rw = cRowArray(j)
nxtChk:
a = Math.Round(Cells(rw, cColArray(x)).Value, 2)
d = Math.Round(Cells(rw + 1, cColArray(x)).Value, 2)
mvSt1 = stColArray(x)
mvEnd1 = lstColArray(x)
b = Math.Round(Cells(rw, cColArray(y)).Value, 2)
c = Math.Round(Cells(rw + 1, cColArray(y)).Value, 2)
mvSt2 = stColArray(y)
mvEnd2 = lstColArray(y)
stDevAB = Math.Sqr((((b - ((b + a) / 2)) ^ 2) + ((a - ((b + a) / 2)) ^ 2)) / 2)
stDevAC = Math.Sqr((((c - ((c + a) / 2)) ^ 2) + ((a - ((c + a) / 2)) ^ 2)) / 2)
stDevBA = Math.Sqr((((a - ((a + b) / 2)) ^ 2) + ((b - ((a + b) / 2)) ^ 2)) / 2)
stDevBD = Math.Sqr((((d - ((d + b) / 2)) ^ 2) + ((d - ((d + b) / 2)) ^ 2)) / 2)
stErrAB = stDevAB / Math.Sqr(2)
stErrAC = stDevAC / Math.Sqr(2)
stErrBA = stDevBA / Math.Sqr(2)
stErrBD = stDevBD / Math.Sqr(2)
If a > 0 And b > 0 Then
chisqrAB = ((b - a) - 0.05) ^ 2 / a
p_val_AB = WorksheetFunction.ChiDist(chisqrAB, 1)
chisqrAC = ((c - a) - 0.05) ^ 2 / a
p_val_AC = WorksheetFunction.ChiDist(chisqrAC, 1)
chisqrBA = ((a - b) - 0.05) ^ 2 / b
p_val_BA = WorksheetFunction.ChiDist(chisqrBA, 1)
chisqrBD = ((d - b) - 0.05) ^ 2 / b
p_val_BD = WorksheetFunction.ChiDist(chisqrBD, 1)
End If
If a > 0 And stDevAB > stDevAC And stErrAB > stErrAC And p_val_AB < p_val_AC Then
For col = mvSt1 To mvEnd1
Cells(rw, col).Insert shift:=xlDown
Next col
ElseIf b > 0 And stDevBA > stDevBD And stErrBA > stErrBD And p_val_BA < p_val_BD Then
For col = mvSt2 To mvEnd2
Cells(rw, col).Insert shift:=xlDown
Next col
End If
If rw > 5 And b = 0 Then
y = y + 1
rw = cRowArray(j) - 1
End If
If rw > 5 And b = 0 And y > cNum Then Exit Sub
rw = rw + 1
GoTo nxtChk
End Sub
I'm stuck at this point.
