I will explain my situation which will hopefully explain what I am trying to do. I have a table that has our staff phone numbers, but I need to be able to see what the next 5 available numbers are.
I have tbl_ext, which is current numbers and tbl_temp, which is used to enter in a "starting" number, dependent on status (managers get 1xxx, sales get 2xxx, etc) . I need to know if it would be possible to "count" the next 5 numbers that are not in tbl_ext and insert these into tbl_temp.
Hopefully this makes some sense, as I am starting to wonder if it is even possible.
The following code will create the next five numbers for extensions that start with '1xxx'. You didn't mention the format of the field (text or number), or if you store Area Code + Exchange + Ext.
You also didn't mntion how many different 'status' there are (1, 2, 3, ...). You can either clone the code and repeat for 1-9 or, you could select the unique high-order digit of all extensions. I can update the answer when you procide more detail.
Public Function Create_Phone_Numbers()
Dim db As Database
Dim rst As Recordset
Dim strSQL As String
Dim i As Integer
Dim iLoop As Integer
Dim iExt As Integer
Dim iStatus As Integer
Set db = CurrentDb
For iStatus = 1 To 9
If iStatus = 999 Then ' Change this line to skip unused numbers
' Do nothing - skip this
Else ' It's a number we want.
strSQL = "SELECT TOP 1 tbl_Ext.PhoneExt FROM tbl_Ext GROUP BY tbl_Ext.PhoneExt HAVING (((tbl_Ext.PhoneExt) Like '" & iStatus & "*')) ORDER BY tbl_Ext.PhoneExt DESC;"
Set rst = db.OpenRecordset(strSQL, dbOpenDynaset)
If Not (rst.EOF And rst.BOF) Then
iExt = rst!PhoneExt
For i = 1 To 5
strSQL = "insert into tbl_Temp (PhoneExt) Select " & iExt + i & " As Expr1;"
db.Execute strSQL
Next i
End If
End If
Next iStatus
rst.Close
Set rst = Nothing
db.Close
Set db = Nothing
End Function
Related
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 am trying to create an update query in MS Access where I will pull a few fields of information from one table if one of the fields matches and the rest are blank. For example:
**Table 1**
SKU Description Weight Lead Time
C210657 NULL NULL NULL
221AB0909 NULL NULL NULL
VA12345 NULL NULL NULL
221AB09 NULL NULL NULL
**Table 2**
SKU Description Weight Lead Time
F-210-223.2 Hammer 2.1 3.1
201-ABF-345 Car 12546.0 65.0
C_210657 Apple 0.2 1.0
34_AA_332 Puppy 5.5 55.0
221 AB 0909 Stereo 12.0 875.0
VA12345_123-A Labor 0.0 0.0
So I want the query to fill in columns 2 through 4 of table 1 with information from table 2. All four of the items in table 1 have a match in table 2, there are just special characters (-, _, ., ), that are in the way. How can I have the query ignore them? Thanks
Which way you go depends on what you're willing to do. If it's a big database, you might want to add a new field [SKU_Index] that is SKU with the special characters removed and link on that.
If that's not a possibility, then you can do a calculated subquery and link on the calculated field...but it can be a little slow.
You would need to write a procedure that removes the special characters from a passed string. Let me know if you would like help with that.
Then you do a query on Table 2 like this:
Select SKU2:RemoveSpecialChars([SKU]), Description, Weight, [Lead Time] From [Table 2];
RemoveSpecialChars() would be your procedure.
You save that query (let's call it PreQuery). Create a new query and bring in PreQuery and Table 1 linking SKU from Table 1 to SKU2 from PreQuery, and update the relevant fields.
Ideally, cause storage is cheap, I would keep a second field without the special characters and perhaps index on it.
Here's example code for how that would work:
Public Function RemoveSpclChars(strIn As String) As String
' Comments : removes any special characters
' Parameters: strIn - string to check
' Returns : resulting string with removed special characters, can be empty
'
Dim lngCounter, intChar As Integer
Dim chrTmp As String * 1
Dim strTmp As String
On Error GoTo PROC_ERR
strTmp = ""
' Walk through the string
For lngCounter = 1 To Len(strIn)
' Get the current character
chrTmp = Mid$(strIn, lngCounter)
intChar = Asc(chrTmp)
' Test if alpha or numeric only
If (intChar >= Asc("a") And intChar <= Asc("z")) Or (intChar >= Asc("0") And intChar <= Asc("9")) Then
strTmp = strTmp & chrTmp
End If
Next lngCounter
PROC_EXIT:
RemoveSpclChars = strTmp
Exit Function
PROC_ERR:
Dim strErr As String
strTmp = "ERROR: " & Trim(Str(Err.Number)) & ":" & Err.Description
Resume PROC_EXIT
End Function
My code takes a file name from TextBox1, opens that file and indexes through all the unique values in column B. It then takes a second file, file name in TextBox2, and filters it based on the current index from the first file. It then takes the filtered results and copies them to a sheet in the new workbook. A new sheet is then generated in the new workbook to paste the next filtered result.
My issue is that I have many rows of data and for some reason the filtered data is not be selected after many iterations. My program selects all filtered data when it starts, but at some point it just begins selecting the headers instead of all the visible cells. Let me know if I am missing something or if there is a quick workaround. Thank you.
Sub NewFileGenerate()
Dim I As Integer
Dim N As Integer
Dim X As Integer
Dim IndexedCell As String
X = 1
Windows(TextBox1.Value).Activate
'Need to count only populated cells
I = Sheets(1).Columns(2).Cells.SpecialCells(xlCellTypeConstants).Count
Set Newbook = Workbooks.Add
For N = 2 To I - 1
Application.CutCopyMode = True
Windows(TextBox1.Value).Activate
IndexedCell = Cells(N, 2).Value
Windows(TextBox2.Value).Activate
With Sheets(1)
With .Range("A1", "Z" & I - 1)
.AutoFilter Field:=5, Criteria1:=IndexedContract
.SpecialCells(xlCellTypeVisible).Copy
End With
End With
Newbook.Activate
ActiveSheet.Paste Destination:=Sheets(X).Range("A1:Z1")
Cells.Select
Selection.Font.Size = 10
Cells.EntireColumn.AutoFit
Cells.Select
X = X + 1
If X > 3 Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Sheet" & X
End If
Application.CutCopyMode = False
Next N
End Sub
I'm guessing that your source worksheet (textbox2.value) has more rows than your index worksheet (textbox1.value). You set I equal to the number of rows in your index worksheet, then you tell the autofilter to only use that number of rows. You need to change the line "With .Range("A1", "Z" & I - 1)" so it picks up all of the rows in your source worksheet.
I'm trying to populate a series of textboxes with random value from a column.
i get the first textbox filled then it returns run time error 3021 - no current record.
i checked the values and the record I'm trying to retrieve doesn't exceed recordcount for the table.
Debug colours rs.move randomrecord.
Dim rs As DAO.Recordset
Dim recordCount As Long
Dim randomRecord As Long
Set rs = CurrentDb.OpenRecordset("SELECT * FROM besede")
rs.MoveLast
rs.MoveFirst
recordCount = rs.recordCount - 1
MsgBox recordCount
Randomize
Dim i As Integer
For i = 1 To 10
randomRecord = Int((recordCount) * Rnd)
rs.Move randomRecord
Controls("t" & i).SetFocus
Controls("t" & i) = rs!test
Next
You are moving the cursor from the current position, so eventually you are trying to read a record at the end of the recordset. Use
rs.MoveFirst before rs.Move randomRecord
to move from the beginning of the recordset.
Check Office Dev Center for more background information on Recordset.Move.
I'm working with Excel project wich helps to calculate the price of any peace of furniture. The first task is to pick all the materials from the database.
This is the code:
Sub Material_search()
Dim cnt As New ADODB.connection
Dim rst As New ADODB.Recordset
Dim rcArray As Variant
Dim sSQL As String
Dim db_path As String, db_conn As String
Dim item As String
item = Replace(TextBox1.Text, " ", "%") ' Search word
sSQL = "Select Data, NomNr, Preke, Matas, Kaina, Tiek from VazPirkPrekes " & _
"Where VazPirkPrekes.PirkVazID IN (SELECT VazPirkimo.PirkVazID FROM VazPirkimo Where VazPirkimo.Sandelys like '%ALIAVOS')" & _
" and Year(VazPirkPrekes.Data)>=2011 and Preke Like '%" + item + "%' and Kaina > 0" & _
" Order by Preke, Data Desc"
db_path = Sheets("TMP").Range("B6").value
db_conn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & db_path & ";"
cnt.Open db_conn
rst.Open sSQL, cnt, adOpenForwardOnly, adLockReadOnly
ListBox1.Clear
If Not rst.EOF Then
rcArray = (rst.GetRows)
rcArray = WorksheetFunction.Transpose(rcArray)
Dim a As Variant
With ListBox1
.ColumnCount = 6
.list = rcArray
.ListIndex = -1
End With
End If
rst.Close: Set rst = Nothing
cnt.Close: Set cnt = Nothing
Label4.Caption = UBound(ListBox1.list) + 1
End Sub
recently I came up with some trouble while querying Access mdb file. The problem is when database file is on local disk, the search works very fast, but when i put database file on server, the search takes 10 times longer, which is not acceptable.
Is there any optimisation for this code ? or is it a server problem
Thanks in advance
That query requires Access' database engine retrieve all 190K rows from both tables. It's not surprising it is slow, and the slowness is compounded when the db engine must retrieve 2 * 190K rows across the network.
If TextBox1.Text contains "foo", this is the statement you're asking the db engine to run:
Select Data, NomNr, Preke, Matas, Kaina, Tiek
from VazPirkPrekes
Where
VazPirkPrekes.PirkVazID IN (
SELECT VazPirkimo.PirkVazID
FROM VazPirkimo
Where VazPirkimo.Sandelys like '%ALIAVOS')
and Year(VazPirkPrekes.Data)>=2011
and Preke Like '%foo%'
and Kaina > 0
Order by Preke, Data Desc
The engine must retrieve all 190K rows from the VazPirkimo table before it can determine which of them include Sandelys values which end with "ALIAVOS". If your selection criterion was for values which start with "ALIAVOS", the engine could use an index on Sandelys to limit the number of rows it must retrieve from VazPirkimo. However, since that approach is probably not an option for you, consider adding a numeric field, Sandelys_group, to VazPirkimo and create an index on Sandelys_group. Give all rows where Sandelys ends with "ALIAVOS" the same Sandelys_group number (1). Then your "IN ()" condition could be this:
SELECT VazPirkimo.PirkVazID
FROM VazPirkimo
Where VazPirkimo.Sandelys_group = 1
The index on Sandelys_group will allow the db engine to retrieve only the matching rows, which will hopefully be a small subset of the 190K rows in the table.
There are other changes you can make to speed up your query. Look at this criterion from your WHERE clause:
Year(VazPirkPrekes.Data)>=2011
That forces the db engine to retrieve all 190K rows from VazPirkPrekes before it can determine which of them are from 2011. With an index on Data, this should be much faster:
VazPirkPrekes.Data >= #2011-01-01# AND VazPirkPrekes.Data < #2012-01-01#
This WHERE criterion will be faster with an index on Kaina:
Kaina > 0
Your ORDER BY begs for indexes on Preke and Data.
Order by Preke, Data Desc
Any or all of those changes could help speed up the query, though I don't know by how much. The killer is this WHERE criterion:
Preke Like '%foo%'
The issue here is similar to the problem with the "Sandelys like" comparison. Since this asks for the rows where Preke contains "foo", rather than starts with "foo", the db engine can't take advantage of an index on Preke to retrieve only the matching rows. It must retrieve all 190K VazPirkPrekes rows to figure out which match. Unless you can use a different criterion for this one, you will be limited as to how much you can speed up the query.
Thanks for the optimization tips, but as I said the problem occurs only when I put data base file on server. And there is not much help from optimization. But I thought about other idea.
The search of empty blank "" returns about 40k records (these records covers everything I need) . So I'm going to put all these records on a distinct sheet on workbook_activate event and later do the query only in that sheet.
Sub Database_upload()
Application.DisplayAlerts = False
On Error Resume Next
Sheets("DATA_BASE").Delete
On Error GoTo 0
Application.DisplayAlerts = False
Sheets.Add
ActiveSheet.name = "DATA_BASE"
Sheets("DATA_BASE").Visible = False: Sheets("DARBALAUKIS").activate
Dim cnt As New ADODB.connection
Dim rcArray As Variant
Dim sSQL As String
Dim db_path As String, db_conn As String
Dim item As String
Dim qQt As QueryTable
item = "" 'search for empty blanks
sSQL = "Select Data, NomNr, Preke, Matas, Kaina, Tiek from VazPirkPrekes " & _
"Where VazPirkPrekes.PirkVazID IN (SELECT VazPirkimo.PirkVazID FROM VazPirkimo Where VazPirkimo.Sandelys like '%ALIAVOS')" & _
" and Year(VazPirkPrekes.Data)>=2011 and Preke Like '%" + item + "%' and Kaina > 0" & _
" Order by Preke, Data Desc"
db_path = Sheets("TMP").Range("B6").value
db_conn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & db_path & ";"
db_conn = "ODBC;DSN=MS Access 97 Database;"
db_conn = db_conn & "DBQ=" & db_path
Set qQt = Sheets("Sheet1").QueryTables.Add(connection:=db_conn, Destination:=Sheets("Sheet1").Range("A1"), Sql:=sSQL)
qQt.Refresh BackgroundQuery:=False
End Sub
Results:
Program takes longer on startup, but the search time is acceptable - for me the problem is solved :)