Option Explicit
Sub query_import_data()
'https://www.youtube.com/watch?v=bXaM2kU4Mzc&feature=youtu.be
'-----------------------------
'Thanks for downloading the code.
'Please visit our channel for a quick explainer on how to use this code.
'Feel free to update the code as per your need and also share with your friends.
'Download free codes from http://vbaa2z.blogspot.com
'Support our channel: youtube.com/vbaa2z
'Author: L Pamai (vbaa2z.team@gmail.com)
'-----------------------------
Dim datarng As Range
Dim lr As Long
Dim wb As Workbook
Dim en_likematch As Boolean
Dim queryResult As Long
Dim cust As String
Dim pdate As String
Dim zip As Long
Application.ScreenUpdating = False
ThisWorkbook.Activate
'Sheets("QueryMaster").activate
Range("E4:R" & Rows.Count).ClearContents
Range("A1").Select
cust = Sheets("QueryMaster").Range("Customer").Value
zip = Sheets("QueryMaster").Range("zip").Value
pdate = Sheets("QueryMaster").Range("Transaction_date").Value
en_likematch = Sheets("QueryMaster").Range("likeMatch").Value
Set wb = Workbooks.Open(Filename:="D:\VbaA2z\2019\Data.xlsx", ReadOnly:=True)
wb.Activate
Sheets("TData").Select
Sheets("TData").AutoFilterMode = False
lr = Sheets("TData").Range("A" & Rows.Count).End(xlUp).Row
Set datarng = ActiveSheet.Range("$A$1:$N$" & lr)
If cust <> "" Then
If en_likematch = True Then
datarng.AutoFilter Field:=1, Criteria1:="=*" & cust & "*", Operator:=xlAnd
Else
datarng.AutoFilter Field:=1, Criteria1:="=" & cust
End If
End If
If zip <> 0 Then
If en_likematch = True Then
datarng.AutoFilter Field:=9, Criteria1:="=*" & zip & "*", Operator:=xlAnd
Else
datarng.AutoFilter Field:=9, Criteria1:="=" & zip
End If
End If
If pdate <> "" Then
datarng.AutoFilter Field:=12, Operator:=xlFilterValues, Criteria2:=Array(2, pdate)
End If
queryResult = Range("A1:A" & lr).SpecialCells(xlCellTypeVisible).Count
If queryResult > 1 Then
Range("A2:N" & lr).SpecialCells(xlCellTypeVisible).Copy
ThisWorkbook.Activate
Sheets("QueryMaster").Select
Range("E4").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Range("A1").Select
Application.CutCopyMode = False
End If
Set datarng = Nothing
wb.Close False
Set wb = Nothing
Application.ScreenUpdating = True
End Sub
No comments:
Post a Comment
Note: only a member of this blog may post a comment.