CODE IS WORKING! THANKS FOR THE HELP!
I am attempting to create a dynamic pivot table that will work on data that varies in the number of rows. Currently, I have 28,300 rows, but this may change daily.
Example of data format as follows:
Case Number Branch Driver
1342 NYC Bob
4532 PHL Jim
7391 CIN John
8251 SAN John
7211 SAN Mary
9121 CLE John
7424 CIN John
Example of finished table:
Driver NYC PHL CIN SAN CLE
Bob 1 0 0 0 0
Jim 0 1 0 0 0
John 0 0 2 1 1
Mary 0 0 0 1 0
Code as follows:
Sub CreateSummaryReportUsingPivot()
' Use a Pivot Table to create a static summary report
' with model going down the rows and regions across
Dim WSD As Worksheet
Dim PTCache As PivotCache
Dim PT As PivotTable
Dim PRange As Range
Dim FinalRow As Long
Dim FinalCol As Long
Set WSD = Worksheets("PivotTable")
'Name active worksheet as "PivotTable"
ActiveSheet.Name = "PivotTable"
' Delete any prior pivot tables
For Each PT In WSD.PivotTables
PT.TableRange2.Clear
Next PT
' Define input area and set up a Pivot Cache
FinalRow = WSD.Cells(Application.Rows.Count, 1).End(xlUp).Row
FinalCol = WSD.Cells(1, Application.Columns.Count). _
End(xlToLeft).Column
Set PRange = WSD.Cells(1, 1).Resize(FinalRow, FinalCol)
Set PTCache = ActiveWorkbook.PivotCaches.Add(SourceType:= _
xlDatabase, SourceData:=PRange)
' Create the Pivot Table from the Pivot Cache
Set PT = PTCache.CreatePivotTable(TableDestination:=WSD. _
Cells(2, FinalCol + 2), TableName:="PivotTable1")
' Turn off updating while building the table
PT.ManualUpdate = True
' Set up the row fields
PT.AddFields RowFields:="Driver", ColumnFields:="Branch"
' Set up the data fields
With PT.PivotFields("Case Number")
.Orientation = xlDataField
.Function = xlCount
.Position = 1
End With
With PT
.ColumnGrand = False
.RowGrand = False
.NullString = "0"
End With
' Calc the pivot table
PT.ManualUpdate = False
PT.ManualUpdate = True
End Sub
They changed the object model for PivotCaches. The method you need in 2007-2010 (that use VBA version 7 instead of version 6) is
PivotCaches.Create
Any reason you are using VBA other than the changing number of rows?
If you are using Excel 2007 / 2010, create a regular table /list (Ctrl-L) from your original data. You can give it a name as well. Then create a Pivot Table and use the table name as the data source. As you add rows your table will expand and you can then just refresh the Pivot Table (F5, or using VBA).
If you are in Excel 2003, you can create dynamic named ranges as well. It's slightly more complex (and a lot more ugly) but I can walk you through it if you are stuck on an older version.
Related
I am new to vbscript and I am creating a script to reduce my day by day duplicate efforts. I have a column in an excel sheet which holds values. There are certain cells under this column where multiple values exists. Now I have an array which has some values which needs to be looked up / searched within each row under this column and delete the row if array values are not present within the row.
I tried to search the array values in the rows using InStr function and it worked if cell contains only one value. Code is attached below.
This sub is not working as expected if cell contains multiple values. e.g. Project 1 [ALT + ENTER] Dummy Project
Hence I tried to use Find and Search methods. I am unable to get the expected results using these methods too.
Fix Version/s
Row 1 - Project 3 a
Row 2 - Project 2 'spaces at the end
Row 3 - Project 4
---------
Project 1
Row 4 - Project 5
Row 5 - Project 1
Find method - No rows deleted
Replace method - Getting syntax error where I used Search method in place of InStr function as below,
If objWorksheet1.Cells(iDelCnt, fixVerColNum).Search(objWorksheet1.Cells(iDelCnt, fixVerColNum).Value, projectFilter(jDelCnt)) <> 0 Then
Please assist. Thanks in advance.
Expected - I expect row 'x' to be deleted if array value doesn't exists in Cells(x,y)
Dim objExcel, objWorkbook, objWorksheet1
Dim iDelCnt, jDelCnt, projectFilter, lRow, fixVerColNum, tempCell, deleteCounter, InStrTest
Set objExcel = CreateObject("Excel.Application")
objExcel.Application.Visible = True
Set objWorkbook = objExcel.Workbooks.Open(filePath) ' Location of the file on drive
Set objWorksheet1 = objWorkbook.Worksheets(1)
projectFilter = Array("Project 1","Project 2", "Project 3")
fixVerColNum = objExcel.Match("Fix Version/s", objWorksheet1.Range("A1:T1"), 0) 'Identify "Fix Version(s)" column number
lRow = objWorksheet1.Range("A1").CurrentRegion.Rows.Count
deleteCounter = 0
For iDelCnt = lRow to 2 Step -1
For jDelCnt = LBound(projectFilter) to UBound(projectFilter)
If InStr(1, objWorksheet1.Cells(iDelCnt, fixVerColNum).Value, projectFilter(jDelCnt), 1) <> 0 Then
deleteCounter = 1
Exit For
Else
deleteCounter = 0
End If
Next
If deleteCounter = 0 Then
objWorksheet1.Rows(iDelCnt).EntireRow.Delete
End If
Next
I want to make an Excel workbook that I have much quicker.
I have a big product database with the product names, quantities, delivery number and delivery date (ProductDB). I put in another sheet the products that I have sold (product names and quantity sold) and want to filter and copy those that are corresponding from the database so I can calculate in the second step the remaining quantity and past the remaining quantity to the database.
Everything is working well and the calculation is good. The only thing is, the Advancedfilter xlfiltercopy option is too slow if I have to input 5000 lines of product names.
I have heard that arrays are much faster. How could I do that? The current way I do it is like this:
Sub UseFilter()
Application.ScreenUpdating = False
Sheet1.Range("G1:Z100000").Cells.Delete
Dim lastrow As Long, c As Range
Dim myrange As Range
Dim rngCell As Range
Dim wksSheet As Worksheet
Dim wksSheetDB As Worksheet
lastrow = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
Sheet1.Columns("G").NumberFormat = "0"
Filter product codes from the database according to sold product codes:
Set myrange = Range("A1:A" & lastrow)
For Each c In myrange
If Len(c.Value) <> 0 Then
ThisWorkbook.Worksheets(Worksheets.Count).Columns("A:D").AdvancedFilter xlFilterCopy, _
Sheet1.Range("A1:A" & lastrow), Sheet1.Range("G1"), False
End If
Next
Sort the filtered list first by product code, then by the delivery number:
Dim lngRowMax As Long
Dim wsf As WorksheetFunction
With Sheet1
lastrow = Cells(Rows.Count, 8).End(xlUp).Row
Range("G1:J" & lastrow).Sort Key1:=Range("G1:G" & lastrow), _
Order1:=xlAscending, Key2:=Range("I1:I" & lastrow), _
Order2:=xlAscending, Header:=xlYes, DataOption1:=xlSortTextAsNumbers
Set wsf = Application.WorksheetFunction
lngRowMax = .UsedRange.Rows.Count
End With
I'm only interested in filtering and copying of the corresponding product information (name (A), quantity (B), delivery nr (C) and date (D)). Does anyone know how I can do that?
Thank you very much in advance. I'm really looking forward for a solution that improves the pace of the file. Currently it is unbelievably slow.
i had the same problem with advanced filter being so slow. you might want to consider using dictionary. for my 2 spreadsheets i wanted to compare i made 2 dictionaries and compared the values and it was so amazingly fast. dictionaries are really easy and a simple google search you can find a ton of tutorials and examples. good luck.
There is a possible solution with dictionaries, but I have only one small issue. I will explain after the code:
'Count num rows in the database
NumRowsDB = ThisWorkbook.Worksheets(Worksheets.Count).Range("A2", Range("A2").End(xlDown)).Rows.Count
' --------------------- SAVE DATABASE DATA -----------------------
'Dictionary for all DB data
Set dbDict = CreateObject("Scripting.Dictionary")
Set dbRange = Range("A2:A" & (NumRowsDB + 1))
For Each SKU In dbRange
If Len(SKU.Value) <> 0 Then
' check if the SKU allready exists, if not create a new array list for that dictionary entry
' a list is necessary because there can be multiple entries in the db range with the same SKU
If Not dbDict.Exists(CStr(SKU.Value)) Then
Set prodList = CreateObject("System.Collections.ArrayList")
dbDict.Add CStr(SKU.Value), prodList
End If
' for this specific product code, save the range where the product information is saved in the dictionary
rangeStr = "A" & SKU.Row & ":D" & SKU.Row
dbDict(CStr(SKU.Value)).Add (rangeStr)
End If
Next
' ----------- READ SALE/Reverse/Consumption INFO ------------------
NumRowsSale = Range("A2", Range("A2").End(xlDown)).Rows.Count
Set saleRange = Range("A2:A" & (NumRowsSale + 1))
Dim unionRange As Range
For Each sale In saleRange
' check if the SKU for the sale exists in db
If Len(sale.Value) <> 0 And dbDict.Exists(CStr(sale.Value)) Then
For Each dbRange In dbDict(CStr(sale.Value))
If unionRange Is Nothing Then
Set unionRange = Range(dbRange)
Else
Set unionRange = Union(unionRange, Range(dbRange))
End If
Next
End If
Next
unionRange.Copy Destination:=Range("G2") 'copy all received ranges to G2
Set dbDict = Nothing
The line "NumRowsDB = ThisWorkbook.Worksheets(Worksheets.Count).Range("A2", Range("A2").End(xlDown)).Rows.Count" is not working. I have to refer to another sheet (the last sheet which is the current database) to get the data. What is the problem that I cannot refer to another sheet in the same workbook?
Thank you for your suggestions.
I have two tables (t1 and t2) and I select two fields from this tables (f1 and f2).
The list Queries contains the selected data. In this case there are 2 entry with 2 rows.
This is the code:
Dim FieldIndexes As New List(Of Integer)
Dim Queries As New List(Of IEnumerable(Of Object()))
For i = 0 To _SqlSyntaxChecker.QueriedTables.Count - 1
FieldIndexes.Clear()
For j = 0 To _SqlSyntaxChecker.DataFields.Count - 1
If _SqlSyntaxChecker.QueriedTables(i).TableName = _SqlSyntaxChecker.DataFields(j).TableName Then FieldIndexes.Add(_SqlSyntaxChecker.DataFields(j).FieldIndexInDataTable)
Next
Dim query = _SqlSyntaxChecker.QueriedTables(i).Rows.Select(Function(Row) FieldIndexes.Select(Function(FieldIndex) Row.Item(FieldIndex)).ToArray)
Queries.Add(query)
For Each item In Queries(i)
_OutputDataTable.Rows.Add(item)
Next
Next
And this is the result:
As you see, everything is ok, I expected this result (it is now not important, that I have on the image 4 rows in one column).
Originally, I wanted to populate the _OutputDataTable outside the for cykle, like so:
Dim FieldIndexes As New List(Of Integer)
Dim Queries As New List(Of IEnumerable(Of Object()))
For i = 0 To _SqlSyntaxChecker.QueriedTables.Count - 1
FieldIndexes.Clear()
For j = 0 To _SqlSyntaxChecker.DataFields.Count - 1
If _SqlSyntaxChecker.QueriedTables(i).TableName = _SqlSyntaxChecker.DataFields(j).TableName Then FieldIndexes.Add(_SqlSyntaxChecker.DataFields(j).FieldIndexInDataTable)
Next
Dim query = _SqlSyntaxChecker.QueriedTables(i).Rows.Select(Function(Row) FieldIndexes.Select(Function(FieldIndex) Row.Item(FieldIndex)).ToArray)
Queries.Add(query)
Next
For Each q In Queries
For Each item In q
_OutputDataTable.Rows.Add(item)
Next
Next
But as you see, the result is wrong:
The result should be the same.
What can cause this?
Your query is linked to i field (using closures). But queries are execute after first cycle, so i already have its last value when query is executed.
You can check "Access to modified closure" topic over internet (mainly it's about delegates but actually same thing works for expression trees).
I am new to scripting and perform lot of activity as an analyst using excel sheets.
I have two files with list of items in it.
File1 contains 1 column
File2 contains 2 columns.
I want to check if the list present in column1 of file2 is same as in column1 of file2. If yes then it should print column1File1, column1File2 and coulmn2File2 in file3 else it should print "NA", column1File2, column2File2 in file3.
Please help, It will simplify my work a lot.
I made this program a while ago, although it will iterate through sheets in 1 workbook, and compare cell by cell, it may set you in the right direction. It would take a cell in 1 "master" sheet and then iterate through each sheet to find that in a particular column. After it found it the counter would increment, then it would take the next cell in the master sheet and so on. you could alter to use multiple books and take whatever cells you want and compare them.
Sub Open_Excel()
'Use worksheetNum as sheet to read/write data
Set currentWorkSheet = objExcel.ActiveWorkbook.Worksheets(worksheetNum)
'How many rows are used in the current worksheet
usedRowsCount = currentWorkSheet.UsedRange.Rows.Count
'Use current worksheet cells for values
Set Cells = currentWorksheet.Cells
'Loop through each row in the worksheet
For curRow = startRow to (usedRowsCount)
'Get computer name to ping to
strEmailAddressSource = Cells(curRow,colEmailAddressSource).Value
strServerSource = Cells(curRow,colHostserverSource).Value
strLocationSource = Cells(curRow,colLocationSource).Value
'make the values unique
strconcatenation = strServerSource & strLocationSource
Call Comparison()
Next
End Sub
'********************************************************************************************
'**** Comparison
'********************************************************************************************
'Comparison test
Sub Comparison()
'choose the worksheets to go through
For worksheetCounter = 6 to 9 'workSheetCount
Set currentWorkSheetComparison = objExcel.ActiveWorkbook.Worksheets(worksheetCounter)
usedRowsCountNew = currentWorkSheetComparison.UsedRange.Rows.Count
'First row to start the comparison from
For rowCompare = 2 to (usedRowsCountNew)
strEmailLot = currentWorkSheetComparison.Cells(rowCompare,colEmailAddressLot).Value
comp1 = StrComp(strEmailAddressSource,strEmailLot,0)
comp2 = StrComp(strconcatenation,reportConcat,0)
'check if the values match
If ((comp1 = 0) AND (comp2 = 0)) THEN
countvalue = countvalue + 1
End If
Next
Next
End Sub
So i have FlexGrid in my VB6 project I'm working on. It has names on each row, and I have a drop down so the user can select what name they want to see more info for, here is what I have.
Dim target_name As String
Dim r As Integer
' Get the name.
target_name = Combo1
If Len(target_name) = 0 Then Exit Sub
' Search for the name, skipping the column heading row.
target_name = LCase$(target_name)
For r = 1 To MSFlexGrid1.Rows - 1
If LCase$(MSFlexGrid1.TextMatrix(r, 0)) = _
target_name Then
' We found the target. Select this row.
MSFlexGrid1.Row = r
MSFlexGrid1.RowSel = r
MSFlexGrid1.Col = 0
MSFlexGrid1.ColSel = MSFlexGrid1.Cols - 1
' Make the row visible.
MSFlexGrid1.TopRow = r
Exit Sub
End If
Next r
That works well, but it shows everything below that name too, I would like it to single out only the name selected.
Any help would be great.
What's the data source of your grid? You can place the filter on the data grid data source, so that as the user chooses the name from your drop down only the selected persons details are returned from the datasource to the grid.
Not exactly what you were asking, but its how I would achieve the result you are wanting.
P.S. I have used FlexGrid in VB6 and I don't know of a way to do what you are asking on the grid (might be there but I never noticed it).