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.
13081715551.xlsm
I'm stuck at this point.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




Reply With Quote
Bookmarks