filter data and find count and sum using vba,Sourav Bhattacharya ,Excel VBA Teacher

Sub setlistbox()

Workbooks("Macro_1.xlsm").Activate
ActiveWorkbook.Sheets("DATABASE").Activate
    Range("AJ3").Select
    Selection.EntireColumn.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
  
    Range("AI3").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Range("AJ3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("AJ3").Select
   
    Dim myrange As Range
    Range(Selection, Selection.End(xlDown)).Select
    Set myrange = Selection
    'MsgBox (myrange.Address)
   
    ActiveSheet.Range(myrange.Address).RemoveDuplicates Columns:=1, Header:=xlNo

    Range("AJ3").Select
    Range(Selection, Selection.End(xlDown)).Select
    Dim options() As String
    ReDim options(Selection.Rows.count) As String
     Dim cell As Object
    Dim count As Integer
    count = 1
    For Each cell In Selection
        options(count) = cell.Value
        count = count + 1
       
    Next cell
    'MsgBox Selection.Rows.count
    For count = 1 To UBound(options)
    'MsgBox (options(count))
    Next count
   
   
   
    ActiveCell.EntireColumn.Delete
    ActiveWorkbook.Sheets("2nd Macro").Activate
    Columns("B:B").Select
    Selection.NumberFormat = "@"
   
    Range("B6").Select
    For i = 1 To UBound(options)
Sheet2.ListBox1.AddItem options(i)

Next i


End Sub

Sub almostfinal()
Dim countarr() As Integer

Dim str1 As String

Workbooks("Macro_1.xlsm").Activate

  ActiveWorkbook.Sheets("2nd Macro").Activate
  
    Range("B6:C200").Select
    Selection.Clear
 
    Range("C1:AG1500").Select
    Selection.Clear
   
   Dim source As Range
    Dim iCol As Long
    Dim nCol As Long
    Dim nRow As Long
  'Dim text As String
  Dim count1 As Integer
  Dim i As Integer
  Dim j As Integer
 
  count1 = 0
   Sheets("2nd Macro").Select
    Columns("B:B").Select
    Selection.NumberFormat = "@"
 
  Range("B6").Select
 
    For i = 0 To Sheet2.ListBox1.ListCount - 1
        If Sheet2.ListBox1.Selected(i) = True Then
       ActiveCell.Value = Sheet2.ListBox1.List(i)
       ActiveCell.Offset(1, 0).Select
       count1 = count1 + 1
      
        End If
    Next i
   ' MsgBox (count1)
   If count1 = 0 Then
    Range("B6").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
     Range("B6:C200").Select
    Selection.Clear
 
    Range("C1:AG1500").Select
    Selection.Clear
   
    Exit Sub
   
    End If
   
   
   ' MsgBox "Selected items are: " & text
     Columns("B:B").EntireColumn.AutoFit
    
     Application.DisplayAlerts = False
On Error Resume Next
Sheets("temp_data").Delete



Worksheets.Add(After:=Worksheets(Worksheets.count)).Name = "temp_data"

ActiveWorkbook.Sheets("temp_data").Select
   
    Columns("A:A").Select
    Selection.NumberFormat = "@"
   
  ActiveWorkbook.Sheets("2nd Macro").Activate
  Range("B5").Select
  Dim pos1 As String
  Dim filterstr As String
  ReDim countarr(count1) As Integer
 
  For i = 1 To count1
 
  
  Range("B5").Select
    Sheets("temp_data").Select
    Range("B1").Select
    Dim signal As Integer
    signal = 0
   
   
      
  ActiveWorkbook.Sheets("2nd Macro").Activate
  Range("B5").Select
  For j = 1 To i
  
   ActiveCell.Offset(1, 0).Select
  
 
  Next j
 
  pos1 = ActiveCell.Address
 ' MsgBox ("pos1" & pos1)
 
    Range("B5").Select
  
ActiveCell.Offset(0, 1).Select
ActiveCell.EntireColumn.Insert
    Range("B5").Select
    Selection.Copy
    Range("C5").Select
    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range(pos1).Select
   
   
    Application.CutCopyMode = False
    Selection.Copy
    ActiveCell.Offset(0, 1).Select
    pos2 = ActiveCell.Address
   ' MsgBox ("pos2" & pos2)
   
    Range(pos2).Select
    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
   ' MsgBox ("check")
  
        Range("C5").Select
        str1 = "$c$5:"
       
        For j = 1 To count1
        ActiveCell.Offset(1, 0).Select
       
       
        Next j
       
        str1 = str1 & ActiveCell.Address
       
    Range(str1).Select
    Selection.Copy
    ActiveWorkbook.Sheets("temp_data").Activate
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("A:A").EntireColumn.AutoFit
    Range("a2").Select
    For j = 1 To count1
    If ActiveCell.Value <> "" Then
Range("a2").Value = ActiveCell.Value

    End If
    ActiveCell.Offset(1, 0).Select
   
    Next j
   
  '  Columns("A:A").Select
  '  Selection.SpecialCells(xlCellTypeBlanks).Select
'    Selection.EntireRow.Delete
   
    'now the filtering part
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    ActiveSheet.Range("$A$1:$A$" & 100).RemoveDuplicates Columns:=1, Header:=xlYes
       ActiveWorkbook.Sheets("DATABASE").Select
     Range("A2:AI100").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
        Sheets("temp_data").Range("A1:A2"), Unique:=False

    Range("I2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("temp_data").Select
    Range("B1").Select
    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
       
        'filtering ends
       
     Range("B1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    
countarr(i) = (Selection.Rows.count)

    Set source = Selection

    nCol = source.Columns.count
    nRow = source.Rows.count
    For iCol = 1 To nCol
        With source.Columns(iCol).Rows(nRow).Offset(1, 0)
            .FormulaR1C1 = "=SUM(R[-" & nRow & "]C:R[-1]C)"
            .Font.Bold = True
        End With
    Next iCol

     Sheets("temp_data").Select
    Range("B1").Select
    Selection.End(xlDown).Select
    Range(Selection, Selection.End(xlToRight)).Select
   
    Selection.Copy
   
     Sheets("2nd Macro").Select
    Range(pos2).Select
    ActiveCell.Offset(0, 5).Select
   
    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
      ActiveWorkbook.Sheets("2nd Macro").Activate
    Columns("C:C").Select
    Selection.Delete Shift:=xlToLeft
      ActiveWorkbook.Sheets("DATABASE").Activate
       Range("A3").Select
    ActiveSheet.ShowAllData
    
      ActiveWorkbook.Sheets("temp_data").Activate
      Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Clear
  Next i
    ActiveWorkbook.Sheets("2nd Macro").Activate
    Range("c5").Select
    ActiveCell.Value = "count"
    ActiveCell.Offset(1, 0).Select
   
  For i = 1 To count1
 ActiveCell.Value = countarr(i) - 1
 ActiveCell.Offset(1, 0).Select

  Next i
  For i = 1 To count1
  countarr(i) = 0
  Next i
 
   Sheets("DATABASE").Select
    Range("I2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Sheets("2nd Macro").Select
    Range("G5").Select
    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
   
    
End Sub


Sub testpos()

Workbooks("Macro_1.xlsm").Activate

  ActiveWorkbook.Sheets("2nd Macro").Activate
 Dim j As Integer
  Dim i As Integer
 
For i = 1 To 4
  Range("B5").Select
  For j = 1 To i

  ' MsgBox (ActiveCell.Address)
   ActiveCell.Offset(1, 0).Select
  
 
  Next j
  MsgBox (ActiveCell.Address)
  Next i
 

End Sub

My stupid advanced filter(with some cool features) macro,Sourav Excel Teacher

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

My stupid version of advanced filter macro,Sourav Bhattacharya,VBA Teacher

Private Sub Worksheet_Change(ByVal Target As Range)

   Dim KeyCells As Range

    Set KeyCells = Range("F2:G2")
   
    If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then

     macro4
      
      
    End If
  
End Sub
 







Sub macro4()

database_clearfilter
clear_result

Workbooks("Macro_1.xlsm").Activate
    Sheets("DATABASE").Activate
ActiveSheet.Range("A2").Select
   
    Dim i As Long
    Dim count As Integer

    Dim str1 As String
    For i = 1 To 500000
    If ActiveCell.Value = "DOA(Month)" Then
    str1 = ActiveCell.Address
    Exit For
    Else
    ActiveCell.Offset(0, 1).Select
End If

   
   
   
   
   
    Next i
    MsgBox (str1)
   ActiveSheet.Range(str1).Select
    For i = 1 To 500000
    If ActiveCell.Value = "" Then
   
    Exit For
    Else
    str1 = ActiveCell.Address
   
   
    ActiveCell.Offset(1, 0).Select
End If

   
   
   
   
   
    Next i
   
 
   MsgBox (str1)
  
    Dim str2 As String
    str2 = "A2:" & str1
    MsgBox (str2)
    Sheets("DATABASE").Activate

    Range(str2).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
        Sheets("Dlr Filter_1st Macro").Range("F1:G2"), Unique:=False
   
    Range("A2").Select
   
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("Dlr Filter_1st Macro").Select
   
    Range("A3").Select
    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
database_clearfilter

End Sub

Sub database_clearfilter()
Workbooks("Macro_1.xlsm").Activate
    Sheets("DATABASE").Activate

If ActiveSheet.AutoFilterMode Or ActiveSheet.FilterMode Then
    ActiveSheet.ShowAllData
End If
End Sub

Sub clear_result()

Workbooks("Macro_1.xlsm").Activate
    Sheets("Dlr Filter_1st Macro").Activate
ActiveSheet.Range("A3").Select
   
    Dim i As Long
    Dim count As Integer

    Dim str1 As String
    For i = 1 To 500000
    If ActiveCell.Value = "DOA(Month)" Then
    str1 = ActiveCell.Address
    Exit For
    Else
    ActiveCell.Offset(0, 1).Select
End If

   
   
   
   
   
    Next i
    MsgBox (str1)
   ActiveSheet.Range(str1).Select
    For i = 1 To 500000
    If ActiveCell.Value = "" Then
   
    Exit For
    Else
    str1 = ActiveCell.Address
   
   
    ActiveCell.Offset(1, 0).Select
End If

   
   
   
   
   
    Next i
   
 
   MsgBox (str1)
  
    Dim str2 As String
    str2 = "A3:" & str1
    MsgBox (str2)
Range(str2).Clear


End Sub

more advanced version of vlookup macro,Sourav VBA Teacher

Sub callvlookup()
Dim selectrange As Range
Dim i As Integer
Dim lookupval As String

Set selectrange = Application.InputBox(prompt:="select the cells containing a lookup value", Type:=8)

Dim selectedarea As String


selectedarea = selectrange.Address
selectedarea = Replace(selectedarea, "$", "")
Dim selectedarea2 As String

'MsgBox (selectedarea)
Dim firstnum As Integer
Dim secondnum As Integer
selectedarea2 = Replace(selectedarea, ":", "")
'MsgBox ("2 is " & selectedarea2)
Dim numbers(2) As String
Dim count As Integer
count = 0

For i = 1 To Len(selectedarea)
If Mid(selectedarea, i, 1) = ":" Then

'MsgBox ("true")
Exit For

Else
count = count + 1

End If


Next i

'MsgBox (count)
For i = 1 To count
If IsNumeric(Mid(selectedarea, i, 1)) = True Then
numbers(1) = numbers(1) + Mid(selectedarea, i, 1)

Else
End If


Next i

firstnum = CInt(numbers(1))
For i = (count + 2) To Len(selectedarea)
If IsNumeric(Mid(selectedarea, i, 1)) = True Then
numbers(2) = numbers(2) + Mid(selectedarea, i, 1)

Else
End If


Next i
secondnum = CInt(numbers(2))

'MsgBox ("firstnum is: " & numbers(1) & "secondnum is: " & numbers(2))
MsgBox ("selectedarea is " & selectedarea)

Dim first As String
first = Mid(selectedarea, 1, InStr(selectedarea, ":") - 1)
Range(first).Select
MsgBox (ActiveCell.Address)

Dim numlookup As Integer
Dim numlookup2 As String
numlookup2 = ""

For i = Len(first) To 1 Step -1

If IsNumeric(Mid(first, i, 1)) = True Then

numlookup2 = numlookup2 + Mid(first, i, 1)

Else
End If






Next i
numlookup2 = StrReverse(numlookup2)

numlookup = (CInt(numlookup2))
MsgBox ("numlookup is :" & numlookup)
MsgBox ("first part of first is : " & Mid(first, 1, (Len(first) - Len(numlookup2))))

Dim realloc As String
realloc = Mid(first, 1, (Len(first) - Len(numlookup2))) & numlookup


For i = 1 To ((secondnum - firstnum) + 1)
realloc = Mid(first, 1, (Len(first) - Len(numlookup2))) & numlookup
Range(realloc).Select

MsgBox (ActiveCell.Address)

If ActiveCell.Value <> "" Then

Call vlookup_macro(ActiveCell.Value)
numlookup = numlookup + 1


Else
Exit For





End If




Next i

End Sub


Sub vlookup_macro(lookupval As String)
Dim temp2 As Integer
Dim count As Integer

Dim selectlookup As Range





'MsgBox (lookupval)

Dim selectrange As Range
Dim selectedarea As String
Set selectrange = Application.InputBox(prompt:="select the cells containing lookup range", Type:=8)
selectedarea = selectrange.Address
selectedarea = Replace(selectedarea, "$", "")
Dim selectedarea2 As String

'MsgBox (selectedarea)
Dim firstnum As Integer
Dim secondnum As Integer
selectedarea2 = Replace(selectedarea, ":", "")
Dim numbers(2) As String

count = 0

For i = 1 To Len(selectedarea)
If Mid(selectedarea, i, 1) = ":" Then

'MsgBox ("true")
Exit For

Else
count = count + 1

End If


Next i

'MsgBox (count)
For i = 1 To count
If IsNumeric(Mid(selectedarea, i, 1)) = True Then
numbers(1) = numbers(1) + Mid(selectedarea, i, 1)

Else
End If


Next i

firstnum = CInt(numbers(1))
For i = (count + 2) To Len(selectedarea)
If IsNumeric(Mid(selectedarea, i, 1)) = True Then
numbers(2) = numbers(2) + Mid(selectedarea, i, 1)

Else
End If


Next i
secondnum = CInt(numbers(2))
'firstnum = CInt(Mid(selectedarea2, 2, 1))
'secondnum = CInt(Mid(selectedarea2, Len(selectedarea2), 1))
'MsgBox ("firstnum is: " & firstnum & "secondnum is: " & secondnum)


Dim first As String
first = Mid(selectedarea, 1, InStr(selectedarea, ":") - 1)
'MsgBox ("selected area is " & selectedarea)

Dim last As Integer



last = CInt(Mid(selectedarea, Len(selectedarea), 1))
'MsgBox ("last is " & last)


Dim firstcolnum As Integer

firstcolnum = CInt((Range(selectedarea & 1).Column))

'MsgBox (firstcolnum)

Dim secondcolnum As Integer


secondcolnum = CInt(Range(Mid(selectedarea, Len(selectedarea) - 1, 1) & 1).Column)



'MsgBox (secondcolnum)

Range(first).Select
'MsgBox (ActiveCell.Address)
Dim coluser As Integer
coluser = CInt(InputBox("Enter the column number"))


'MsgBox (coluser)


'MsgBox (firstcolnum)

'MsgBox (coluser)

'For i = 1 To (coluser - 1)



'ActiveCell.Offset(0, 1).Select




'Next i

'MsgBox (ActiveCell.Address)
Dim test1 As Integer
Dim test2 As String
Dim result As String
result = ""
Dim k As Integer
k = (secondnum - firstnum) + 1

Dim j As Integer
Dim compare() As Integer
ReDim compare(k) As Integer

Dim x, y As Integer
Dim temp As Integer


Dim match As Integer
match = InputBox("choose match option 1(less than) or 0(exact) or -1(greater than)")



For i = 1 To ((secondnum - firstnum) + 1)

'MsgBox ("lookupval " & lookupval & " and activecell.Value " & ActiveCell.Value & " are being compaired ")

If IsNumeric(lookupval) Then

If IsNumeric(ActiveCell.Value) Then
If CInt(lookupval) = CInt(ActiveCell.Value) Then
'MsgBox ("found")
For j = 1 To (coluser - 1)



ActiveCell.Offset(0, 1).Select




Next j
'MsgBox ("The result is " & ActiveCell.Value)
result = (ActiveCell.Value)
Exit For


Else
ActiveCell.Offset(1, 0).Select
End If
Else

'MsgBox ("got an issue")

Exit Sub

End If
Else
If Trim(lookupval) = Trim(ActiveCell.Value) Then
'MsgBox ("found")
For j = 1 To (coluser - 1)



ActiveCell.Offset(0, 1).Select




Next j
'MsgBox ("The result is " & ActiveCell.Value)
result = (ActiveCell.Value)
Exit For


Else
ActiveCell.Offset(1, 0).Select
End If
End If




Next i
If Not result = "" Then

'MsgBox (result)

Dim position As Range
Set position = Application.InputBox(prompt:="select the cell for the lookup value to appear", Type:=8)
position.Value = result


End If

If result = "" And match = 1 And IsNumeric(lookupval) = True Then
Range(first).Select
'MsgBox (ActiveCell.Address)

For i = 1 To ((secondnum - firstnum) + 1)

'MsgBox ("lookupval " & lookupval & " and activecell.Value " & ActiveCell.Value & " are being compaired ")
If CInt(ActiveCell.Value) < CInt(lookupval) Then

compare(i) = CInt(ActiveCell.Value)
'For j = 1 To (coluser - 1)



'ActiveCell.Offset(0, 1).Select




'Next j

ActiveCell.Offset(1, 0).Select

Else
ActiveCell.Offset(1, 0).Select
End If









Next i
For x = 1 To UBound(compare())

For y = x + 1 To UBound(compare)

If compare(x) > compare(y) Then

temp = compare(x)

compare(x) = compare(y)
compare(y) = temp
Else
End If

count = count + 1




Next y





Next x


For i = 1 To UBound(compare())

'MsgBox (compare(i))


Next i

Range(first).Select
'MsgBox (ActiveCell.Address)

For i = 1 To ((secondnum - firstnum) + 1)

If CInt(ActiveCell.Value) = CInt(compare(UBound(compare))) Then

For j = 1 To (coluser - 1)



ActiveCell.Offset(0, 1).Select




Next j
'MsgBox (ActiveCell.Value)
result = ActiveCell.Value

Exit For

Else
ActiveCell.Offset(1, 0).Select
End If



Next i

ElseIf result = "" And match = -1 And IsNumeric(lookupval) = True Then
For x = 1 To UBound(compare)
compare(x) = 0



Next x

Range(first).Select
'MsgBox (ActiveCell.Address)

For i = 1 To ((secondnum - firstnum) + 1)

'MsgBox ("lookupval " & lookupval & " and activecell.Value " & ActiveCell.Value & " are being compaired ")
If CInt(ActiveCell.Value) > CInt(lookupval) Then

compare(i) = CInt(ActiveCell.Value)
'For j = 1 To (coluser - 1)



'ActiveCell.Offset(0, 1).Select




'Next j

ActiveCell.Offset(1, 0).Select

Else
ActiveCell.Offset(1, 0).Select
End If









Next i
For x = 1 To UBound(compare())

For y = x + 1 To UBound(compare)

If compare(x) > compare(y) Then

temp = compare(x)

compare(x) = compare(y)
compare(y) = temp
Else
End If

count = count + 1




Next y





Next x


For i = 1 To UBound(compare())

'MsgBox (compare(i))
If CInt(compare(i)) <> 0 Then
temp2 = compare(i)
Exit For


End If


Next i
'MsgBox ("the temp2 is " & temp2)

Range(first).Select
'MsgBox (ActiveCell.Address)

For i = 1 To ((secondnum - firstnum) + 1)

If CInt(ActiveCell.Value) = CInt(temp2) Then

For j = 1 To (coluser - 1)



ActiveCell.Offset(0, 1).Select




Next j
'MsgBox (ActiveCell.Value)
result = ActiveCell.Value

Exit For

Else
ActiveCell.Offset(1, 0).Select
End If



Next i




End If

Set position = Application.InputBox(prompt:="select the cell for the lookup value to appear", Type:=8)
position.Value = result


End Sub