Automatically Filter data and copy the filtered data and merge it in a sheet with a dynamically created name using VBA,VBA Teacher Sourav,Kolkata 08910141720

Sub automatefilter()
'This is to get the todays date and i like this date as part of the name of the new sheet,however this is not necessary

Dim mydate As String
mydate = Format(Now(), "MMM DD YYYY")

'We need to remove all filters first




Workbooks(ActiveWorkbook.Name).Activate
    Sheets("Sheet1").Activate
    Dim str3 As String
Dim fieldname As Integer


Dim InputBoxRangeCancelVariable As Range

  
ActiveSheet.Cells.Select

Selection.ClearFormats

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

'Now we need to get the data by which we are going to filter



    On Error Resume Next

    Set InputBoxRangeCancelVariable = Application.InputBox(Prompt:="Please select the cell which contains basis of the filter", Type:=8)

    On Error GoTo 0

    If InputBoxRangeCancelVariable Is Nothing Then

       MsgBox ("You have not selected anything")
       GoTo 0
    Else

        str3 = InputBoxRangeCancelVariable.Value
      

    End If
'We need to find the address of the range to be filtered which is expanding horizantally


    Sheets("Sheet1").Activate
ActiveSheet.Range("A1").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
   
   
   
   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
   str1 = Replace(str1, "$", "")
  
 For i = 1 To Len(str1)
If IsNumeric(Mid(str1, i, 1)) = False Then

temp = temp + Mid(str1, i, 1)

End If




 Next i


fieldname = Range(temp & 1).Column

 
    Dim str2 As String
    str2 = "A1:" & str1
 
   Selection.Clear



     ActiveSheet.Range(str2).AutoFilter Field:=fieldname, Criteria1:=str3
  

  
'as you have seen we are able to get the filtered data ,now let's create a sheet and copy paste the filtered data in the new sheet
'or there is a old sheet and we have to append the filtered data inside it,that'sour requirement

'Now let's create another sheet






str3 = str3 + " " + mydate

Dim signal As Boolean
signal = False


For i = 1 To ActiveWorkbook.Sheets.count



If ActiveWorkbook.Sheets(i).Name = str3 Then
signal = True
End If




Next i

If signal = False Then
'create the sheet as it is not present,and copy the filtered data with headers


Worksheets.Add(After:=Worksheets(Worksheets.count)).Name = str3
'copy and paste
Sheets("Sheet1").Select

 Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets(str3).Select
    Range("A1").Select
   
    ActiveSheet.Paste
Else
'here the sheet is already present


Sheets(str3).Activate
If Range("A1").Value <> "" Then



Sheets("Sheet1").Select

 Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
   
  Else
  Sheets("Sheet1").Select

 Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy

End If

Sheets(str3).Select
Range("A1").Select
While ActiveCell.Value <> ""
ActiveCell.Offset(1, 0).Select




Wend

ActiveSheet.Paste


End If
Application.CutCopyMode = False

  
  
0:
End Sub

Connect to access database ,run query and fetch the result in excel using VBA,VBA Teacher Sourav,Kolkata 09748184075

Sub getDataFromAccess()
' Click on Tools, References and select
' the Microsoft ActiveX Data Objects 2.0 Library

Dim DBFullName As String
Dim Connect As String, Source As String
Dim Connection As ADODB.Connection
Dim Recordset As ADODB.Recordset
Dim Col As Integer

Cells.Clear

' Database path info

' Your path will be different
DBFullName = "C:\Users\sourav\Desktop\Database6.accdb"
' Open the connection
Set Connection = New ADODB.Connection
Connect = "Provider=Microsoft.ACE.OLEDB.12.0;"
Connect = Connect & "Data Source=" & DBFullName & ";"
Connection.Open ConnectionString:=Connect

' Create RecordSet
Set Recordset = New ADODB.Recordset
With Recordset
' Filter Data
Source = "SELECT * FROM QWERTY"
'Source = "SELECT * FROM Customers WHERE [Job Title] = 'Owner' "
.Open Source:=Source, ActiveConnection:=Connection

' MsgBox “The Query:” & vbNewLine & vbNewLine & Source

' Write field names

For Col = 0 To (Recordset.Fields.Count - 1)


Range("A1").Offset(0, Col).Value = Recordset.Fields(Col).Name
Next

' Write recordset
Range("A1").Offset(1, 0).CopyFromRecordset Recordset
End With
ActiveSheet.Columns.AutoFit
Set Recordset = Nothing
Connection.Close
Set Connection = Nothing
End Sub