Public blankcell As String
Sub starttimer(colnum As Integer, rownum As Integer, param As String, firstpart As String, sheetname As String, temppos As String)
Application.OnTime Now + TimeValue("00:00:01"), "'increment_count_by_1 """ & colnum & """,""" & rownum & """,""" & param & """,""" & firstpart & """,""" & sheetname & """,""" & temppos & "'"
End Sub
Sub increment_count_by_1(colnum As Integer, rownum As Integer, param As String, firstpart As String, sheetname As String, temppos As String)
Call starttimer(colnum, rownum, param, firstpart, sheetname, temppos)
Range(blankcell).Value = CInt(Range(blankcell).Value) + 1
If CInt(Range(blankcell).Value) = 20 Then
Call endtimer(colnum, rownum, param, firstpart, sheetname, temppos)
End If
End Sub
Sub endtimer(colnum As Integer, rownum As Integer, param As String, firstpart As String, sheetname As String, temppos As String)
Application.OnTime Now + TimeValue("00:00:01"), "'increment_count_by_1 """ & colnum & """,""" & rownum & """,""" & param & """,""" & firstpart & """,""" & sheetname & """,""" & temppos & "'", schedule:=False
Range(blankcell).Value = ""
Call samesheetdellcellsetup(colnum, rownum, firstpart, sheetname, temppos)
Call repaintsheet(firstpart)
End Sub
Sub message(colnum As Integer, rownum As Integer, param As String, firstpart As String, sheetname As String, temppos As String)
Call samesheetcellsetup(colnum, rownum, param, firstpart, sheetname, temppos)
MsgBox ("this will be shown for 20 seconds")
findblankcell
Range(blankcell).Value = 0
Call increment_count_by_1(colnum, rownum, param, firstpart, sheetname, temppos)
End Sub
Sub findblankcell()
Dim ws As Worksheet
Set ws = Sheets("sheet1")
Dim colnum As Integer
colnum = (Range("A1").Column)
For Each cell In ws.Columns(colnum).Cells
If IsEmpty(cell) = True Then cell.Select: Exit For
Next cell
blankcell = ActiveCell.Address
End Sub
Sub test1()
Dim sheetname As String
Dim i As Long
Dim j As Long
Dim selectlookup As Range
Dim temppos As String
temppos = "a1"
Dim selectrange As Range
Dim selectedarea As String
Set selectrange = Application.InputBox(prompt:="select the cells for the range", Type:=8)
selectedarea = selectrange.Address
'MsgBox (selectedarea)
Dim selectedarea2 As String
selectedarea2 = Replace(selectedarea, "$", "")
'MsgBox (selectedarea2)
Dim firstpart As String
firstpart = Left(selectedarea2, InStr(selectedarea2, ":") - 1)
'MsgBox (firstpart)
Dim colnum1 As Integer
colnum1 = (Range(firstpart).Column)
'MsgBox (colnum1)
Dim lastpart As String
lastpart = Right(selectedarea2, (Len(selectedarea2) - Len(firstpart)) - 1)
'MsgBox (lastpart)
Dim colnum2 As Integer
colnum2 = (Range(lastpart).Column)
'MsgBox (colnum2)
Dim colnum As Integer
colnum = (colnum2 - colnum1) + 1
Dim rownum As Integer
Dim rownumholder As String
rownumholder = ""
For i = (InStr(selectedarea2, ":") + 1) To Len(selectedarea2)
If IsNumeric(Mid(selectedarea2, i, 1)) Then
rownumholder = rownumholder + Mid(selectedarea2, i, 1)
Else
End If
Next i
'MsgBox (rownumholder)
rownum = CInt(rownumholder)
'MsgBox ("colnum is : " & colnum & " rownum is : " & rownum)
'Dim arr1(3, 2) As Integer
Dim arr1() As String
ReDim arr1(colnum, rownum) As String
Sheets("sheet1").Select
Range(firstpart).Select
Dim pos As String
For i = 1 To rownum
For j = 1 To colnum
arr1(j, i) = (ActiveCell.Value)
ActiveCell.Offset(0, 1).Select
Next j
ActiveCell.Offset(1, 0).Select
For j = 1 To colnum
ActiveCell.Offset(0, -1).Select
Next j
Next i
For i = 1 To rownum
For j = 1 To colnum
'MsgBox (arr1(j, i))
Next j
Next i
'MsgBox (" number of columns in the 2d array " & UBound(arr1, 1))
'MsgBox (" number of rows in the 2d array " & UBound(arr1, 2))
Dim i2 As Long
Dim j2 As Long
Dim selectlookup2 As Range
Dim result As Integer
result = 0
Dim selectrange2 As Range
Set selectrange2 = Application.InputBox(prompt:="select the cells for the criterias", Type:=8)
selectedarea2 = selectrange2.Address
'MsgBox (selectedarea)
Dim selectedarea22 As String
selectedarea22 = Replace(selectedarea2, "$", "")
'MsgBox (selectedarea2)
Dim firstpart2 As String
firstpart2 = Left(selectedarea22, InStr(selectedarea22, ":") - 1)
'MsgBox (firstpart)
Dim colnum12 As Integer
colnum12 = (Range(firstpart2).Column)
'MsgBox (colnum1)
Dim lastpart2 As String
lastpart2 = Right(selectedarea22, (Len(selectedarea22) - Len(firstpart2)) - 1)
'MsgBox (lastpart)
Dim colnum22 As Integer
colnum22 = (Range(lastpart2).Column)
'MsgBox (colnum2)
Dim colnum225 As Integer
colnum225 = (colnum22 - colnum12) + 1
Dim rownum2 As Integer
Dim rownumholder2 As String
rownumholder2 = ""
For i = (InStr(selectedarea22, ":") + 1) To Len(selectedarea22)
If IsNumeric(Mid(selectedarea22, i, 1)) Then
rownumholder2 = rownumholder2 + Mid(selectedarea22, i, 1)
Else
End If
Next i
'MsgBox (rownumholder)
rownum2 = CInt(rownumholder2)
'MsgBox ("colnum is : " & colnum & " rownum is : " & rownum)
'Dim arr1(3, 2) As Integer
Dim arr2() As String
ReDim arr2(colnum225, rownum2) As String
Sheets("sheet1").Select
Range(firstpart2).Select
For i2 = 1 To rownum2
For j2 = 1 To colnum225
arr2(j2, i2) = (ActiveCell.Value)
ActiveCell.Offset(0, 1).Select
Next j2
ActiveCell.Offset(1, 0).Select
For j2 = 1 To colnum225
ActiveCell.Offset(0, -1).Select
Next j2
Next i2
For i2 = 1 To rownum2
For j2 = 1 To colnum225
'MsgBox (arr2(j2, i2))
Next j2
Next i2
'MsgBox (" number of columns in the 2d array " & UBound(arr1, 1))
'MsgBox (" number of rows in the 2d array " & UBound(arr1, 2))
'Now the real deal
ReDim arr3(colnum, rownum) As String
Dim resultarr() As String
ReDim resultarr(colnum, rownum) As String
For i2 = 1 To rownum2
For j2 = 1 To colnum225
arr3(j2, i2) = arr2(j2, i2)
Next j2
Next i2
For i = 1 To rownum
For j = 1 To colnum
'MsgBox (arr3(j, i))
Next j
Next i
Dim checkvals() As Integer
ReDim checkvals(colnum) As Integer
Dim count1 As Integer
count1 = 0
Dim checkint As Integer
checkint = 0
Dim checkint2 As Integer
checkint2 = 0
Dim k As Integer
Dim l As Integer
sheetname = InputBox("Please result sheet name")
test_sheet (sheetname)
For i = 1 To rownum
For l = 1 To rownum
For j = 1 To colnum
For k = 1 To colnum
If arr3(j, i) <> "" Then
'MsgBox ("arr3 value " & arr3(j, i) & " and arr1 value " & arr1(k, l) & " are being compaired")
If IsNumeric(arr3(j, i)) And IsNumeric(arr1(k, l)) Then
If (arr3(j, i)) = (arr1(k, l)) Then
'MsgBox ("arr3 value " & arr3(j, i) & " and arr1 value " & arr1(k, l) & " are matched numerically")
'MsgBox ("true")
checkint = checkint + 1
Else
End If
ElseIf (Not IsNumeric(arr3(j, i))) And (Not IsNumeric(arr1(k, l))) Then
If (arr3(j, i)) = (arr1(k, l)) Then
'MsgBox ("arr3 value " & arr3(j, i) & " and arr1 value " & arr1(k, l) & " are matched as string")
'MsgBox ("true")
checkint = checkint + 1
End If
ElseIf (InStr(arr3(j, i), "<") <> 0) Or (InStr(arr3(j, i), ">") <> 0) Then
If j = k Then
'MsgBox ("arr3 value " & arr3(j, i) & " and arr1 value " & arr1(k, l) & " are being compaired")
If CBool(Evaluate(Replace(Replace("arr1(k, l) arr3(j, i)", "arr1(k, l)", arr1(k, l)), "arr3(j, i)", arr3(j, i)))) = True Then
checkint2 = checkint2 + 1
'MsgBox ("the value of checkint2 " & checkint2)
'MsgBox ("true")
Else
End If
Else
End If
Else
End If
Else
End If
Next k
'MsgBox ("exiting k look for checkint " & checkint)
'MsgBox ("the value of checkint is " & checkint)
'checkint = 0
'MsgBox ("the value of checkint2 " & checkint2)
If checkint2 >= 1 Then
checkint = checkint + 1
End If
checkint2 = 0
Next j
For j = 1 To colnum
If arr3(j, i) <> "" Then
count1 = count1 + 1
Else
End If
Next j
If count1 = checkint And checkint <> 0 Then
result = 1
Else
End If
'MsgBox ("exiting j look for checkint " & checkint & " count1 is " & count1 & "for " & l)
'MsgBox ("exiting j look for " & l & " time")
count1 = 0
checkint = 0
'MsgBox ("the value of result is " & result)
If result <> 0 Then
Sheets(sheetname).Activate
Range(temppos).Select
For j = 1 To colnum
ActiveCell.Value = arr1(j, l)
ActiveCell.Offset(0, 1).Select
Next j
ActiveCell.Offset(1, 0).Select
For j = 1 To colnum
ActiveCell.Offset(0, -1).Select
Next j
temppos = ActiveCell.Address
End If
result = 0
Next l
Next i
'For i = 1 To rownum
'For j = 1 To colnum
'MsgBox (resultarr(j, i))
'Next j
'Next i
'MsgBox (firstpart)
Sheets("sheet1").Select
Range(firstpart).Select
Dim param As String
param = ActiveCell.Value
Call setupcells(sheetname, temppos, param, rownum)
Dim choice As Integer
Dim temparrfinal() As String
ReDim temparrfinal(colnum, rownum) As String
choice = InputBox("1 for same sheet 2 for the different sheet")
If choice = 1 Then
Sheets(sheetname).Activate
'MsgBox (temppos)
Range(temppos).Select
While ActiveCell.Value <> param
ActiveCell.Offset(-1, 0).Select
Wend
For i = 1 To rownum
For j = 1 To colnum
temparrfinal(j, i) = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
Next j
ActiveCell.Offset(1, 0).Select
For j = 1 To colnum
ActiveCell.Offset(0, -1).Select
Next j
Next i
test_sheet ("temp_data")
Sheets("sheet1").Select
Range(firstpart).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("temp_data").Activate
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
'For i = 1 To rownum
'For j = 1 To colnum
'MsgBox (temparrfinal(j, i))
'Next j
'Next i
Sheets("sheet1").Select
Range(firstpart).Select
param = ActiveCell.Value
'Application.ScreenUpdating = True
Call message(colnum, rownum, param, firstpart, sheetname, temppos)
'Application.Wait Now + TimeValue("00:00:20")
'Call samesheetcellsetup(colnum, rownum, param, sheetname, temppos)
End If
End Sub
Sub repaintsheet(firstpart As String)
Sheets("temp_data").Select
Range("a1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("sheet1").Activate
Range(firstpart).Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End Sub
Sub test_check()
Dim k As Integer
Dim arr1() As String
Dim colnum1 As Integer
colnum1 = 3
ReDim arr1(colnum1) As String
Dim i As Integer
Dim j As Integer
For i = 1 To 3
arr1(i) = (InputBox("Please enter for arr1"))
Next i
Dim arr2() As String
Dim colnum As Integer
Dim rownum As Integer
colnum = 3
rownum = 4
Dim testval() As String
ReDim testval(colnum, rownum) As String
ReDim arr2(colnum, rownum) As String
For i = 1 To rownum
For j = 1 To colnum
arr2(j, i) = j
Next j
Next i
Sheets("sheet2").Select
Range("a1").Select
For i = 1 To rownum
For j = 1 To colnum
ActiveCell.Value = arr2(j, i)
ActiveCell.Offset(0, 1).Select
Next j
For j = 1 To colnum
ActiveCell.Offset(0, -1).Select
Next j
ActiveCell.Offset(1, 0).Select
Next i
For i = 1 To rownum
For j = 1 To colnum
'MsgBox (arr2(j, i))
Next j
Next i
Dim signal As Integer
signal = 0
For k = 1 To colnum1
For i = 1 To rownum
For j = 1 To colnum
MsgBox (arr1(k) & " " & arr2(j, i))
If arr1(k) = arr2(j, i) Then
testval(j, i) = 0
Else
testval(j, i) = 1
End If
Next j
Next i
Next k
For i = 1 To rownum
For j = 1 To colnum
'MsgBox (arr2(j, i))
MsgBox ("check val is " & testval(j, i))
Next j
Next i
End Sub
Sub anothertest()
Dim i As Integer
i = 5
For i = 1 To 5
If i = 3 Then
continue
End If
MsgBox (i)
Next i
End Sub
Sub test5()
Dim s As String
s = "sourav"
MsgBox (InStr(s, "o"))
End Sub
Sub setupcells(sheetname As String, temppos As String, param As String, rownum As Integer)
Sheets(sheetname).Activate
Dim pos1 As String
Dim pos2 As String
Dim i As Long
Range(temppos).Select
While ActiveCell.Value <> param
ActiveCell.Offset(-1, 0).Select
Wend
pos1 = ActiveCell.Address
Dim tempholder() As String
ReDim tempholder(rownum) As String
Dim count As Integer
For i = 1 To rownum
tempholder(i) = ActiveCell.Value
ActiveCell.Offset(1, 0).Select
Next i
For i = 1 To rownum
For j = i + 1 To rownum
If tempholder(i) = tempholder(j) Then
tempholder(j) = ""
End If
Next j
Next i
Range(pos1).Select
For i = 1 To rownum
ActiveCell.Value = tempholder(i)
ActiveCell.Offset(1, 0).Select
Next i
Range(pos1).Select
For i = 1 To rownum
If ActiveCell.Value = "" Then
ActiveCell.EntireRow.Delete
ActiveCell.Offset(1, 0).Select
End If
ActiveCell.Offset(1, 0).Select
Next i
End Sub
Sub calltestsheet()
Dim sheetname As String
sheetname = InputBox("Please result sheet name")
test_sheet (sheetname)
End Sub
Sub test_sheet(sheetname As String)
Application.DisplayAlerts = False
On Error Resume Next
Sheets(sheetname).Delete
Worksheets.Add(After:=Worksheets(Worksheets.count)).name = sheetname
End Sub
Sub samesheetcellsetup(colnum As Integer, rownum As Integer, param As String, firstpart As String, sheetname As String, temppos As String)
Dim i As Long
Dim j As Long
Dim temparrfinal() As String
ReDim temparrfinal(colnum, rownum) As String
Sheets(sheetname).Activate
'MsgBox (param)
'MsgBox (temppos)
Range(temppos).Select
While ActiveCell.Value <> param
ActiveCell.Offset(-1, 0).Select
Wend
'MsgBox (ActiveCell.Address)
For i = 1 To rownum
For j = 1 To colnum
temparrfinal(j, i) = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
Next j
ActiveCell.Offset(1, 0).Select
For j = 1 To colnum
ActiveCell.Offset(0, -1).Select
Next j
Next i
Sheets("sheet1").Select
Range(firstpart).Select
For i = 1 To rownum
For j = 1 To colnum
ActiveCell.Value = temparrfinal(j, i)
ActiveCell.Offset(0, 1).Select
Next j
ActiveCell.Offset(1, 0).Select
For j = 1 To colnum
ActiveCell.Offset(0, -1).Select
Next j
Next i
End Sub
Sub samesheetdellcellsetup(colnum As Integer, rownum As Integer, firstpart As String, sheetname As String, temppos As String)
Dim i As Long
Dim j As Long
Sheets("sheet1").Select
Range(firstpart).Select
For i = 1 To rownum
For j = 1 To colnum
ActiveCell.Value = ""
ActiveCell.Offset(0, 1).Select
Next j
ActiveCell.Offset(1, 0).Select
For j = 1 To colnum
ActiveCell.Offset(0, -1).Select
Next j
Next i
End Sub
Sub col_insert()
'
' Macro3 Macro
'
Sheets("sheet1").Select
Range("A1").Select
Selection.EntireColumn.Insert
End Sub
Sub col_delete()
Sheets("sheet1").Select
Range("A1").Select
Selection.EntireColumn.Delete
End Sub
No comments:
Post a Comment