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