Filter a dynamic range with multiple criteria and save each filtered result in predefined sheet using VBA,VBA Teacher Sourav,Kolkata 08910141720

Function RemoveDupesColl(MyArray As Variant) As Variant
'DESCRIPTION: Removes duplicates from your array using the collection method.
'NOTES: (1) This function returns unique elements in your array, but
' it converts your array elements to strings.

'-----------------------------------------------------------------------
    Dim i As Long
    Dim arrColl As New Collection
    Dim arrDummy() As Variant
    Dim arrDummy1() As Variant
    Dim item As Variant
    ReDim arrDummy1(LBound(MyArray) To UBound(MyArray))

    For i = LBound(MyArray) To UBound(MyArray) 'convert to string
        arrDummy1(i) = CStr(MyArray(i))
    Next i
    On Error Resume Next
    For Each item In arrDummy1
       arrColl.Add item, item
    Next item
    Err.Clear
    ReDim arrDummy(LBound(MyArray) To arrColl.Count + LBound(MyArray) - 1)
    i = LBound(MyArray)
    For Each item In arrColl
       arrDummy(i) = item
       i = i + 1
    Next item
    RemoveDupesColl = arrDummy
End Function


Sub filterandpastedata()


Sheets("Sheet2").Select
If ActiveSheet.AutoFilterMode Or ActiveSheet.FilterMode Then
    On Error Resume Next
    ActiveSheet.ShowAllData
End If


Dim uniquedata()
Dim samplerange As Range

 Set samplerange = ActiveSheet.Range("E2", ActiveSheet.Range("E2").End(xlDown))
'MsgBox (samplerange.Rows.Count)
ReDim Preserve uniquedata(samplerange.Rows.Count)
Dim dict As Object
Dim length As Long
length = 0
Range("E2").Select
While ActiveCell.Value <> ""

uniquedata(length) = ActiveCell.Value
length = length + 1
ActiveCell.Offset(1, 0).Select
Wend

'For length = LBound(uniquedata) To UBound(uniquedata) - 1
'MsgBox (uniquedata(length))
'Next length
Dim uniquedatafinal()
uniquedatafinal = RemoveDupesColl(uniquedata)
'For length = LBound(uniquedatafinal) To UBound(uniquedatafinal) - 1
'MsgBox (uniquedatafinal(length))
'Next length


'now we found the unique names ,let us first delete anysheet containing such unique names and create sheets containing those names
Dim tempsheetname As String
 With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With
   
  For length = LBound(uniquedatafinal) To UBound(uniquedatafinal) - 1
tempsheetname = (uniquedatafinal(length))

For Each wks In Application.Worksheets
        If wks.Name = tempsheetname Then wks.Delete
    Next

Next length

 For length = LBound(uniquedatafinal) To UBound(uniquedatafinal) - 1
     cntsheets = Application.Sheets.Count
    Set NewSheet = Application.Worksheets.Add(After:=Worksheets(cntsheets))
    NewSheet.Name = uniquedatafinal(length)
    Next length
   
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With

'Now creating sheets is done ,let us go back the data sheet and remove any filter from the sheet

Sheets("Sheet2").Select



Dim dataforfilter As String


For length = LBound(uniquedatafinal) To UBound(uniquedatafinal) - 1
dataforfilter = Replace(ActiveSheet.Range("E1").CurrentRegion.Address, "$", "")
ActiveSheet.Range(dataforfilter).AutoFilter Field:=1, Criteria1:=uniquedatafinal(length), Operator:=xlFilterValues
ActiveSheet.Range(dataforfilter).AutoFilter Field:=4, Criteria1:="=Yes", Operator:=xlFilterValues

ActiveSheet.Range("E1").CurrentRegion.Select
Selection.Copy

Sheets(uniquedatafinal(length)).Select
Range("A1").PasteSpecial xlPasteValues

Sheets("Sheet2").Select
If ActiveSheet.AutoFilterMode Or ActiveSheet.FilterMode Then
    On Error Resume Next
    ActiveSheet.ShowAllData
End If

Next length

If ActiveSheet.AutoFilterMode Then

     ActiveSheet.AutoFilterMode = False

End If

End Sub

Connect and get data from microsoft access database in excel using vba

Option Explicit

Sub ExportDataToAccess()

    Dim ConnObj As ADODB.Connection
    Dim RecSet As ADODB.Recordset
    Dim ConnCmd As ADODB.Command
    Dim ColNames As ADODB.Fields
    Dim DataSource As String
    Dim intLoop As Integer
   
    'Define the data source
    DataSource = "C:\Users\sourav\Desktop\A732CreatingForms_1.accdb"

    'Create a new connection object & a new command object
    Set ConnObj = New ADODB.Connection
    Set ConnCmd = New ADODB.Command

    'Create a new connection
    With ConnObj
        .Provider = "Microsoft.ACE.OLEDB.12.0"    'For *.ACCDB Databases
        .ConnectionString = DataSource
        .Open
    End With
   
    'This will allow the command object to use the Active Connection
    ConnCmd.ActiveConnection = ConnObj

    'Define the Query String & the Query Type.
    ConnCmd.CommandText = "SELECT * from Employees;"
    ConnCmd.CommandType = adCmdText

    'Exectue the Query & Get the column Names.
    Set RecSet = ConnCmd.Execute
    Set ColNames = RecSet.Fields
   
    'Populate the header row of the Excel Sheet.
    For intLoop = 0 To ColNames.Count - 1
        Cells(1, intLoop + 1).Value = ColNames.Item(intLoop).Name
    Next
   
    'Dump the data in the worksheet.
    Range("A2").CopyFromRecordset RecSet
   
    'Close the Connection
    ConnObj.Close

End Sub

Copy excel data to another workbook using vba,VBA Teacher Sourav,Kolkata 08910141720

Sub copydatatoanotherworkbook()
'first we need to copy the data
Sheets("Firstvbasheet").Select
Range("H1:J14").Select
Selection.Copy


Workbooks.Add
ActiveSheet.Paste Destination:=Range("A1")
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:="C:\Users\sourav\Desktop\temp.xlsx"
ActiveWorkbook.Close

Application.DisplayAlerts = True

End Sub

Automating Pivot Table using VBA,VBA Teacher Sourav,Kolkata 08910141720

Sub pivotvba()
 With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With
For Each wks In Application.Worksheets
        If wks.Name = "Pivot_Table" Then wks.Delete
    Next

 cntsheets = Application.Sheets.Count
    Set NewSheet = Application.Worksheets.Add(After:=Worksheets(cntsheets))
    NewSheet.Name = "Pivot_Table"
   
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With
 Application.DisplayAlerts = True
  Dim pt As PivotTable
  Dim pc As PivotCache
  Dim pf As PivotField
  Dim pi As PivotItem

'set the pivotcache
Sheets("Data").Select
Set pc = ActiveWorkbook.PivotCaches.Create(xlDatabase, Sheets("Data").Range("A3").CurrentRegion)

'create the pivot table
Sheets("Pivot_Table").Select
Set pt = ActiveSheet.PivotTables.Add(pc, Range("A3"), "Pivot_Table_1")

'put the fields

With pt
'.PivotFields("Salesperson").Orientation = xlColumnField
.PivotFields("Category").Orientation = xlRowField
.PivotFields("Salesperson").Orientation = xlColumnField
.PivotFields("Revenue").Orientation = xlDataField
'set the number format

.DataBodyRange.NumberFormat = "$#,##0.00"

'classic view

.InGridDropZones = True


'switch back from classic view
.InGridDropZones = False

'add calculated field

.CalculatedFields.Add "Eligible for bonus", "= IF(Revenue >1500,1,0)", True
.PivotFields("Eligible for bonus").Orientation = xlDataField
'Changing the caption of the calculated field,removing the sum of part
.DataPivotField.PivotItems("Sum of Eligible for bonus").Caption = "Eligible for bonus ? "

'changing the number format of the callculated field so that it becomes only 1 and 0

.PivotFields("Eligible for bonus ? ").NumberFormat = "#,##0"
'converting 1 and 0 to yes and no

.PivotFields("Eligible for bonus ? ").NumberFormat = """Yes"";;""No"""

'Add region column as report filter
.PivotFields("Region").Orientation = xlPageField


End With
'Setting default filter

Set pf = pt.PivotFields("Region")
With pf
   For Each pi In pf.PivotItems
   If pi.Name = "East" Then
   pi.Visible = True
   Else
   pi.Visible = False
   End If
  
   Next pi
 End With

'setting filter in a more customized way,suppose
'we want to see revenue generated by eastern region with
'the category beverages,we already filtered the data by east
'now let us filter the filtered table by a cirtain category

Set pf = pt.PivotFields("Category")
With pf
   For Each pi In pf.PivotItems
   If pi.Name = "Beverages" Then
   pi.Visible = True
   Else
   pi.Visible = False
   End If
  
   Next pi
 End With

'Suppose we want to filter column by both east and west

Set pf = pt.PivotFields("Region")
With pf
   For Each pi In pf.PivotItems
   If pi.Name = "East" Or pi.Name = "West" Then
   pi.Visible = True
   Else
   pi.Visible = False
   End If
  
   Next pi
 End With
'Suppose we want to filter the row by both beverages and candy
Set pf = pt.PivotFields("Category")
With pf
   For Each pi In pf.PivotItems
   If pi.Name = "Beverages" Or pi.Name = "Candy" Then
   pi.Visible = True
   Else
   pi.Visible = False
   End If
  
   Next pi
 End With

'Update the pivot table

ThisWorkbook.RefreshAll
End Sub

Arrays in VBA

Sub DeclaringArrays()

'Declare Array with range 0,1,2,3

Dim MyArray(0 To 3) As Variant

'Declare Array with range 0,1,2,3

Dim MyArray(3) As Variant

'Declare Array with range 1,2,3

Dim MyArray(1 To 3) As Variant

'Declare Array with range 2,3,4

Dim MyArray(2 To 4) As Variant

'DYNAMIC ARRAYS

'Declare Array with Dynamic Range

Dim MyArray() As Variant

'Resize Array with range 0,1,2,3,4

ReDim MyArray(0 To 4)

'ASSIGN VALUES TO AN ARRAY

MyArray(0) = 100

MyArray(1) = 200

MyArray(2) = 300

MyArray(3) = 400

MyArray(4) = 500

MyArray(5) = 600 '<<< Will Return an error because there is not 5th element.

'LOOP THROUGH ARRAYS

'Using For Loop

Dim i As Long

For i = LBound(MyArray) To UBound(MyArray)

Debug.Print MyArray(i)

Next

'Using For Each Loop

Dim Elem As Variant

For Each Elem In MyArray

Debug.Print Elem

Next

'USE ERASE

'Declare Static Array

Dim MyArray(0 To 3) As Long

Erase MyArray '<<< All Values will be set to 0.

'Declare Dynamic Array

Dim MyArray() As Long

ReDim MyArray(0 To 3)

Erase MyArray '<<< Array is erased from memory.

'USE REDIM

Dim MyArray() As Variant

MyArray(0) = "MyFirstElement"

'Old Array with "MyFirstElement" is now deleted.

ReDim MyArray(0 To 4)

Dim MyArray() As Variant

MyArray(0) = "MyFirstElement"

'Old Array with "MyFirstElement" is now Resized With Original Content Kept in Place.

ReDim Preserve MyArray(0 To 4)

'USING MULTIDIMENSIONAL ARRAYS

'Declare two dimensional array

Dim MultiDimArray(0 To 3, 0 To 3) As Integer

Dim i, j As Integer

'Assign values to array

For i = LBound(MultiDimArray, 1) To UBound(MultiDimArray, 1)

For j = LBound(MultiDimArray, 2) To UBound(MultiDimArray, 2)

MultiDimArray(i, j) = i + j

Next j

Next i

'Print values from array.

For i = LBound(MultiDimArray, 1) To UBound(MultiDimArray, 1)

For j = LBound(MultiDimArray, 2) To UBound(MultiDimArray, 2)

Debug.Print MultiDimArray(i, j)

Next j

Next i

End Sub

Attribute VB_Name = "Arrays"