Covert SQL Code to VBA

[ayazgreat]

Hi All

I have downloaded attached workbook from a web side and the code used in this work is in SQL , which are difficult for me to understand I want to know that if attached workbook code can be converted to VBA.

Thanks in advance

[bakerman]

This is only for copying the results, not for filling the CB's.
If you want that changed to VBA also, just ask.
Also change the range of dataset to "B12:K12"

Private Sub cmdShowData_Click()

Dim rngTarget As Range, i As Integer
Application.ScreenUpdating = False
Sheets("View").Range("dataSet").CurrentRegion.Offset(1).ClearContents
With Worksheets("data")
Set rngTarget = .Range("A1:J" & .Cells(Rows.Count, 1).End(xlUp).Row)
With rngTarget
For i = 1 To 3
.AutoFilter i + 2, Choose(i, cmbProducts.Text, cmbRegion.Text, cmbCustomerType.Text)
Next
.Offset(1).SpecialCells(xlCellTypeVisible).Copy Sheets("View").Range("B13")
.AutoFilter
End With
End With
Application.ScreenUpdating = True

End Sub

[ayazgreat]

Thanks bakerman for your reply but you have converted only one macro of attached workbook there are more macros/code in attached workbook


Private Sub cmdReset_Click()
'clear the data
cmbProducts.Clear
cmbCustomerType.Clear
cmbRegion.Clear
Sheets("View").Visible = True
Sheets("View").Select
Range("dataSet").Select
Range(Selection, Selection.End(xlDown)).ClearContents
End Sub

Private Sub cmdShowData_Click()
'populate data
strSQL = "SELECT * FROM [data$] WHERE "
If cmbProducts.Text <> "" Then
strSQL = strSQL & " [Product]='" & cmbProducts.Text & "'"
End If

If cmbRegion.Text <> "" Then
If cmbProducts.Text <> "" Then
strSQL = strSQL & " AND [Region]='" & cmbRegion.Text & "'"
Else
strSQL = strSQL & " [Region]='" & cmbRegion.Text & "'"
End If
End If

If cmbCustomerType.Text <> "" Then
If cmbProducts.Text <> "" Or cmbRegion.Text <> "" Then
strSQL = strSQL & " AND [Customer Type]='" & cmbCustomerType.Text & "'"
Else
strSQL = strSQL & " [Customer Type]='" & cmbCustomerType.Text & "'"
End If
End If

If cmbProducts.Text <> "" Or cmbRegion.Text <> "" Or cmbCustomerType.Text <> "" Then
'now extract data
closeRS

OpenDB

rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic
If rs.RecordCount > 0 Then
Sheets("View").Visible = True
Sheets("View").Select
Range("dataSet").Select
Range(Selection, Selection.End(xlDown)).ClearContents

'Now putting the data on the sheet
ActiveCell.CopyFromRecordset rs
Else
MsgBox "I was not able to find any matching records.", vbExclamation + vbOKOnly
Exit Sub
End If

'Now getting the totals using Query
If cmbProducts.Text <> "" And cmbRegion.Text <> "" And cmbCustomerType.Text <> "" Then
strSQL = "SELECT Count([data$].[Call ID]) AS [CountOfCall ID], [data$].[Resolved] " & _
" FROM [Data$] WHERE ((([Data$].[Product]) = '" & cmbProducts.Text & "' ) And " & _
" (([Data$].[Region]) = '" & cmbRegion.Text & "' ) And (([Data$].[Customer Type]) = '" & cmbCustomerType.Text & "' )) " & _
" GROUP BY [data$].[Resolved];"

closeRS
OpenDB

rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic
If rs.RecordCount > 0 Then
Range("L6").CopyFromRecordset rs
Else
Range("L6:M7").Clear
MsgBox "There was some issue getting the totals.", vbExclamation + vbOKOnly
Exit Sub
End If
End If
End If
End Sub

Private Sub cmdUpdateDropDowns_Click()
strSQL = "Select Distinct [Product] From [data$] Order by [Product]"
closeRS
OpenDB
cmbProducts.Clear

rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic
If rs.RecordCount > 0 Then
Do While Not rs.EOF
cmbProducts.AddItem rs.Fields(0)
rs.MoveNext
Loop
Else
MsgBox "I was not able to find any unique Products.", vbCritical + vbOKOnly
Exit Sub
End If

'----------------------------
strSQL = "Select Distinct [Region] From [data$] Order by [Region]"
closeRS
OpenDB
cmbRegion.Clear

rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic
If rs.RecordCount > 0 Then
Do While Not rs.EOF
cmbRegion.AddItem rs.Fields(0)
rs.MoveNext
Loop
Else
MsgBox "I was not able to find any unique Region(s).", vbCritical + vbOKOnly
Exit Sub
End If
'----------------------
strSQL = "Select Distinct [Customer Type] From [data$] Order by [Customer Type]"
closeRS
OpenDB
cmbCustomerType.Clear

rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic
If rs.RecordCount > 0 Then
Do While Not rs.EOF
cmbCustomerType.AddItem rs.Fields(0)
rs.MoveNext
Loop
Else
MsgBox "I was not able to find any unique Customer Type(s).", vbCritical + vbOKOnly
Exit Sub
End If
End Sub

[bakerman]

Here they are.
1st clears all
2nd fills CB's
3rd gets desired data


Private Sub cmdReset_Click()
'clear the data
cmbProducts.Clear
cmbCustomerType.Clear
cmbRegion.Clear
With Sheets("View")
.Visible = True
.Range("dataSet").CurrentRegion.Offset(1).ClearContents
End With
End Sub

Private Sub cmdUpdateDropDowns_Click()

sn = Sheets("data").Range("C3:E472")
For j = 1 To 3
With CreateObject("System.Collections.ArrayList")
For jj = 1 To UBound(sn, 1)
If sn(jj, j) <> vbNullString Then
If Not .Contains(CStr(sn(jj, j))) Then .Add CStr((sn(jj, j)))
End If
Next
.Sort
Choose(j, cmbProducts, cmbRegion, cmbCustomerType).List = Application.Transpose(.toarray)
End With
Next

End Sub

Private Sub cmdShowData_Click()

Dim rngTarget As Range, i As Integer
Application.ScreenUpdating = False
Sheets("View").Range("dataSet").CurrentRegion.Offset(1).ClearContents
With Worksheets("data")
Set rngTarget = .Range("A1:J" & .Cells(Rows.Count, 1).End(xlUp).Row)
With rngTarget
For i = 1 To 3
.AutoFilter i + 2, Choose(i, cmbProducts.Text, cmbRegion.Text, cmbCustomerType.Text)
Next
.Offset(1).SpecialCells(xlCellTypeVisible).Copy Sheets("View").Range("B13")
.AutoFilter
End With
End With
Application.ScreenUpdating = True

End Sub

[ayazgreat]

Thanks for your replay but following codes are giving compile and syntax error


Private Sub cmdShowData_Click()

Dim rngTarget As Range, i As Integer
Application.ScreenUpdating = False
Sheets("View").Range("dataSet").CurrentRegion.Offset(1).ClearContents
With Worksheets("data")
Set rngTarget = .Range("A1:J" & .Cells(Rows.Count, 1).End(xlUp).Row)
With rngTarget
For i = 1 To 3
.AutoFilter i + 2, Choose(i, cmbProducts.Text, cmbRegion.Text, cmbCustomerType.Text)
Next
.Offset(1).SpecialCells(xlCellTypeVisible).Copy Sheets("View").Range("B13")
.AutoFilter
End With
End With
Application.ScreenUpdating = True

End Sub

[bakerman]

Works fine for me.

[ayazgreat]

Thanks Bakerman , it is working fine now