I am trying to create a pivot table using VBScript. I think I am close to achieving it, but I do not know how to create the report filter and set up the filter for "Internal", or how to use sum instead of count in the values.
That is what I have now:
xlA1 = 1
xlDatabase = 1
xlRowField = 1
xlColumnField = 2
xlFilterField = 3
Set xlBook1 = objExcel.WorkBooks.Open(ws_path & "FINAL.xlsx")
set rngData =xlBook1.Sheets("NONPO").Usedrange
set rngReport = xlBook1.Sheets("NONPO").Range("CE1")
set pvtCache = xlBook1.pivotCaches.add(xlDatabase, rngData.address(true, true, xlA1, true))
set pvtTable = pvtCache.createPivotTable(rngReport, "Pivot1")
pvtTable.pivotFields("Date").orientation =xlRowField
pvtTable.pivotFields("Country Code").orientation = xlColumnField
pvtTable.pivotFields("Agent Type").orientation = xlFilterField
'*****Here I should Use filter as "Internal"*****
pvtTable.pivotFields("Hours").orientation = xlsum *****xlsum is not working*****
should work like this...
With pvtTable.pivotFields("Hours")
.orientation = 4
.Function = xlSum
End With
I believe this is what you want.
pt.AddDataField(pt.PivotFields("Hours"), "Hours", _
Excel.XlConsolidationFunction.xlSum)
So, the whole thing should look kind of like this (modify for your specific needs).
Private Sub CreatePivotTable(tableName As String)
Dim targetSheet As Excel.Worksheet = ExcelApp.Sheets.Add
Dim ptName As String = "MyPivotTable"
'We'll assume the passed table name exists in the ActiveWorkbook
targetSheet.PivotTableWizard(Excel.XlPivotTableSourceType.xlDatabase, _
tableName, targetSheet.Range("A5"))
targetSheet.Select()
Dim pt As Excel.PivotTable = targetSheet.PivotTables(1)
'To be professional or merely resuable, the name could be passed as parameter
With pt.PivotFields("Order Date")
.Orientation = Excel.XlPivotFieldOrientation.xlRowField
.Position = 1
End With
pt.AddDataField(pt.PivotFields("Order Total"), "Order Count", _
Excel.XlConsolidationFunction.xlCount)
pt.AddDataField(pt.PivotFields("Order Total"), "Total for Date", _
Excel.XlConsolidationFunction.xlSum)
'--OR--
'AddPivotFields(pt, "Order Total", "Order Count", _
' Excel.XlConsolidationFunction.xlCount)
'AddPivotFields(pt, "Order Total", "Total For Date", _
' Excel.XlConsolidationFunction.xlSum)
Marshal.ReleaseComObject(pt)
Marshal.ReleaseComObject(targetSheet)
End Sub
Related
I'm new to Vb6.
I haven't inserted data in my database and when I run the program, an error shows No Value given for one or more required parameters
Here's the code:
Dim list As ListItem, r As Integer
If recset.State = adStateOpen Then recset.Close
recset.Open "SELECT StudentId, LastName, FirstName, MiddleName FROM Students ORDER BY StudentId", rainCon, adOpenStatic, adLockOptimistic
If recset.RecordCount > 1 Then
MsgBox "No Data Found!", vbInformation, ""
Else
ListView1.ListItems.Clear
Do While Not recset.EOF
r = r + 1
Set list = ListView1.ListItems.Add(, , r)
list.SubItems(1) = recset(0).Value
list.SubItems(2) = recset(1).Value
list.SubItems(3) = recset(2).Value
list.SubItems(4) = recset(3).Value
recset.MoveNext
Loop
End If
Then highlights recset.Open part. How to control or fix this error?
When I tried to re-check my code and database multiple times. I found out that there was a missing attribute in my students table. The code was fully functional.
Find out the full working code.
Private Sub cmdAddItemtoListBox_Click()
'Enter Code here....
End Sub
Change database path, name, and table as per your data.
Output Screenshot
Dim xCon As New ADODB.Connection
Dim rsTable As New ADODB.Recordset
Dim StrSqlQuery As String
Dim Counter As Integer
Dim list As ListItem
If xCon.State = 1 Then xCon.Close
xCon.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Test\Test.mdb;Persist Security Info=False"
'
StrSqlQuery = ""
StrSqlQuery = "Select * from Data Order by PrintSl"
If rsTable.State = 1 Then rsTable.Close
rsTable.CursorLocation = adUseClient
rsTable.Open StrSqlQuery, xCon, adOpenStatic, adLockReadOnly
If rsTable.RecordCount > 0 Then
rsTable.MoveFirst
ListView1.ListItems.Clear
ListView1.ColumnHeaders.Add , , "ID"
ListView1.ColumnHeaders.Add , , "Customer Name"
ListView1.ColumnHeaders.Add , , "Address"
ListView1.ColumnHeaders.Add , , "Pincode"
ListView1.ColumnHeaders.Add , , "Amount"
Do While Not rsTable.EOF
Counter = ListView1.ListItems.Count + 1
Set list = ListView1.ListItems.Add(, , Counter)
list.ListSubItems.Add , , rsTable!CUSTOMERNAME
list.ListSubItems.Add , , rsTable!ADDRESS1
list.ListSubItems.Add , , rsTable!pin
list.ListSubItems.Add , , rsTable!LOAN_AMOUNT
rsTable.MoveNext
Loop
Else
MsgBox "No record found in the table.", vbCritical
End If
If rsTable.State = 1 Then rsTable.Close
If xCon.State = 1 Then xCon.Close
MsgBox "Record Add Successfully", vbInformation
The setup is: an Excel table with some usernames and filenames (as files are photos in some directory). The aim is to create a Word document based on data from selected row by changing variables in template to real username and adding photo to it. The trouble is in positioning and setting properties of that photo. I used Selection.InlineShapes.AddPicture method due to Selection.Shapes.AddPicture method returned error (Run-time error '438': Object doesn't support this property or method) to me. So, the following is my actual code, and I hope someone could help me. Thanks in advance!
Option Explicit
Sub CreateDocs()
Const wdReplaceAll = 2
Dim user_name As String, user_surname As String, user_patronymic As String
Dim user_type As String, user_type_num As Integer, user_country As String
Dim user_pic As String, pic As Object
Dim wrd As Object, doc As Object
Dim length As Integer
Dim ind As Integer
Dim pict As Object
ind = ActiveCell.Row
With Sheets("SHEET_NAME")
user_name = .Cells(ind, 4)
user_surname = .Cells(ind, 3)
user_type = .Cells(ind, 22)
user_pic = .Cells(ind, 25)
End With
Set wrd = CreateObject("Word.Application")
wrd.Visible = True
Set doc = wrd.Documents.Add(ThisWorkbook.Path & "\SUBPATH\TMPL.dotx")
Set pic = wrd.Selection.InlineShapes.AddPicture( _
Filename:=ThisWorkbook.Path & "\SUBPATH\" & user_pic, _
LinkToFile:=False, _
SaveWithDocument:=True _
)
pic.ConvertToShape
' THE NEXT 4 CODE LINES DOESN'T WORK AT ALL
' I have the same error here:
' Run-time error '438': Object doesn't support this property or method
pic.LockAspectRatio = msoTrue
pic.Left = 197
pic.Top = 191
pic.Width = 179
With wrd.Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "%user_name%"
.Replacement.Text = user_name
.Execute Replace:=wdReplaceAll
.Text = "%user_surname%"
.Replacement.Text = user_surname
.Execute Replace:=wdReplaceAll
.Text = "%user_type%"
.Replacement.Text = user_type
.Execute Replace:=wdReplaceAll
End With
doc.SaveAs ThisWorkbook.Path & "\SUBPATH\" & user_name & ".docx"
doc.Close False
Set doc = Nothing
wrd.Quit False
Set wrd = Nothing
End Sub
Try creating another variable (let's call it picShape) and setting it to the result of ConverttoShape. So,
Dim picShape As Object
.....
Set picShape = pic.ConvertToShape
picShape.LockAspectRatio = msoTrue
picShape.Left = 197
picShape.Top = 191
picShape.Width = 179
I wish I could provide a fuller explanation for this, but I rarely work with late-binding. From the looks of the Local window, it doesn't seem like pic.ConvertToShape actually changes the underlying type of pic (although it does change the actual picture from an inlineshape to a shape). So, either you can't change the type at that point, or this method does not affect the variable to which it is applied in the way you might expect.
Suppose an Excel sheet has a column named Student Names and the column has duplicate values. Say,
Student
=======
Arup
John
Mike
John
Lisa
Arup
Using VBScript, how can I get unique values as below?
Arup
John
Lisa
Mike
The VBScript tool for getting unique items is a dictionary: add all the items as keys to a dictionary and dictionary.Keys() will return an array of the - per definitionem - unique keys. In code:
Dim aStudents : aStudents = Array("Arup", "John", "Mike", "John", "Lisa", "Arup")
WScript.Echo Join(aStudents)
Dim aUniqStudents : aUniqStudents = uniqFE(aStudents)
WScript.Echo Join(aUniqStudents)
' returns an array of the unique items in for-each-able collection fex
Function uniqFE(fex)
Dim dicTemp : Set dicTemp = CreateObject("Scripting.Dictionary")
Dim xItem
For Each xItem In fex
dicTemp(xItem) = 0
Next
uniqFE = dicTemp.Keys()
End Function
output:
Arup John Mike John Lisa Arup
Arup John Mike Lisa
Alternatively, since your source data is in an Excel spreadsheet, you could use SQL to fill an ADODB Recordset:
Option Explicit
Dim filePath, sheetName
filePath = "C:\path\to\excel\workbook.xlsx"
sheetName = "Sheet1"
Dim connectionString
connectionString = _
"Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=""" & filePath & """;" & _
"Extended Properties=""Excel 12.0;HDR=No"""
Dim sql
sql = "SELECT DISTINCT Student FROM [" & sheetName & "$]"
Dim rs
Set rs = CreateObject("ADODB.Recordset")
rs.Open sql, connectionString
Do Until rs.EOF
WScript.Echo rs("StudentName")
Loop
If you don't want a Dictionary you can use the following to compare each element in the array to itself.
Info = Array("Arup","John","Mike","John","Lisa","Arup")
x = 0
z = ubound(Info)
Do
x = x + 1
Do
z = z - 1
If x = z Then
Info(x) = Info(z)
ElseIf Info(x) = Info(z) Then
Info(x) = ""
End If
Loop Until z=0
z = ubound(Info)
Loop Until x = ubound(Info)
For each x in Info
If x <> "" Then
Unique = Unique & Chr(13) & x
End If
Next
MsgBox Unique
I am having a problem while searching for an item in datagridview
here is my code but whenever i search for an item which already exist in the database, it is telling not found
If txtfirstname.Text = "" Then
MsgBox("Please enter first name!")
Else
Dim totalrow As Integer = DataGridView1.RowCount - 2
Dim rowin As Integer
Dim flag As Boolean = False
Dim sear As String = CStr(txtfirstname.Text)
For rowin = 0 To totalrow
Dim id As String = DataGridView1.Item(0, rowin).Value
If sear = id Then
DataGridView1.ClearSelection()
DataGridView1.Rows(rowin).Selected = True
DataGridView1.CurrentCell = DataGridView1.Item(0, rowin)
flag = True
Exit Sub
Else
flag = False
End If
Next rowin
If flag = False Then
MessageBox.Show("Firstname " & txtfirstname.Text & " is not found in database.", "Search Information", MessageBoxButtons.OK, MessageBoxIcon.Information)
End If
End If
By setting
Dim totalrow As Integer = DataGridView1.RowCount - 2
you are always missing the last record in your dataset.
Try
Dim totalrow As Integer = DataGridView1.RowCount - 1
to set the upper bound value of your For loop.
This is the code i wrote in order to First open a csv file as excel, then find the required three columns, n then read data from them n save the data into another variables showing them in textbox. As about the csv file, it contains many columns out of which my focus is on only 3 columns under title ID, L, Lg.
Problem is Excel doesnt actually open but Excel.exe process runs in task manager.
But by this point its not the compile error; Compile error comes at 'Next' Statement. It says Compile Error: Next without For!!!!
I am Confused with this one. Please help me with this one, Thanks in Advance.
Private Sub cmdFind_Click()
Dim xlApp As Excel.Application
Set xlApp = New Excel.Application
Dim X As Double, Y As Double, FleetID As String
Dim F As String, FCol As Integer, LCol As Integer, LgCol As Integer, Srno As Integer, I As Integer
Dim xlWbook As Workbook
Dim xlSht As Excel.Worksheet
Set xlWbook = xlApp.Workbooks.Open("C:\Users\saurabhvyas\Desktop\test VB2\testfile.csv")
xlApp.Visible = True
Set xlSht = xlWbook.Worksheets("sheet1")
For I = 1 To 8 Step 1
If xlSht.Cells(I, 1).Value = "ID" Then
FCol = I
Else
If xlSht.Cells(I, 1).Value = "L" Then
LCol = I
Else
If xlSht.Cells(I, 1).Value = "Lg" Then
LgCol = I
End If
Next I
Set Srno = 2
Do
If xlSht.Cells(FCol, Srno).Value = Str$(txtF.Text) Then
Set X = xlSht.Cells(LCol, Srno).Value
Set Y = xlSht.Cells(LgCol, Srno).Value
End If
Srno = Srno + 1
Loop While xlSht.Cells(FCol, Srno).Value = vbNullString
txtL.Text = Str$(X)
txtLg.Text = Str$(Y)
xlWbook.Close
xlApp.Quit
Excel.Application.Close
Set xlSht = Nothing
Set xlWbook = Nothing
Set xlApp = Nothing
End Sub
You can open CSV format text files and operate on them using ADO with the Jet Provider's Text IISAM. Much less clunky than automating Excel. Or you can read the lines as text and Split() them on commas.
What you're doing does open Excel, but you haven't asked Excel to be visible... though I have no idea why you'd want that.
What are you really trying to do?
As for your compile error, that's because you are missing some End Ifs.
Write it as:
For I = 1 To 8 Step 1
If xlSht.Cells(I, 1).Value = "ID" Then
FCol = I
Else
If xlSht.Cells(I, 1).Value = "L" Then
LCol = I
Else
If xlSht.Cells(I, 1).Value = "Lg" Then
LgCol = I
End If
End If
End If
Next I
Or as:
For I = 1 To 8 Step 1
If xlSht.Cells(I, 1).Value = "ID" Then
FCol = I
ElseIf xlSht.Cells(I, 1).Value = "L" Then
LCol = I
ElseIf xlSht.Cells(I, 1).Value = "Lg" Then
LgCol = I
End If
Next I