So I am running a Do loop that cycles through a list. I used the 'index' function to calculate the value in the cell. I have a cell that is set up as the 'index' and another cell set up as the value, which is where the index function resides.
The script will start with 'index' = 1 the run. Once it's done, the script adds 1 to the 'index' and the script runs again. This continues until the cell is 0.
Most of the time this runs without any issues, but every once in a while the loop doesn't add correctly. So what happens is the loop occurs but without adding 1 to the index therefore staying on the same value over and over again. This will happen maybe 2 or 3 iterations before finally adding 1 to the index.
Any idea why this is happening? It's really frustrating because this is used to email a large audience with reports that are unique to user. So when it glitches like this, some users are receiving incorrect reports or multiple reports.
Thank you!
Do
y = Worksheets("index").Range("district_num")
xlsheet.Range("A2:Z150000").ClearContents
Set db = OpenDatabase(DbLoc)
SQL = "SELECT DISTINCT district_num, district_name, district_manager_name, last_name2, first_name2, " & _
"district_mgr_job_title, district_mgr_ee_id, DM_email_email_tbl " & _
"FROM Contacts " & _
"WHERE district_num = " & y
'Execute query and populate the recordset'
Set rs = db.OpenRecordset(SQL, dbOpenSnapshot)
'Paste Access data in Excel worksheet'
xlsheet.Range("A2").CopyFromRecordset rs
Application.Cursor = xlDefault
'Skips over empty zones'
If Range("A2") <> vbNullString Then
Call Sheet5.DM_auto_email
Else
Sheets("ZD_contact_list").Select 'Important to go back to the contact list so script can continue to run'
End If
Worksheets("Index").Range("district_num_index") = Worksheets("Index").Range("district_num_index") + 1
Loop Until y = 0
Related
The initial problem that led me to learn VBA is as follows:
You have a table that can be up to 10,000 rows (several hundred pages) long in a Word document. The table has a title in the form of a paragraph above the first row. This title is styled such that it links to a Table of Contents (Style = "Caption"). The table must be broken at the last row on each page, and the title must be inserted before the new table but in a different style that is not linked to the Table of Contents(Style = "Caption Cont").
The first page will look like this:
The second page will look like this:
My first solution was relatively hackey and not at all elegant. I've managed to put together the following solution that works quite well. However, the initial process of determining the row number at which the table crosses pages is pretty slow due to the use of Range.Information. I'm wondering if there's a faster way to determine the bottom row on the page.
Putting the document into wdNormalView shaves off about a second per page, even with Application.ScreenUpdating = False...
The program requires that your cursor is somewhere inside the table, which is fine and not a functionality I wish to remove.
It currently does about 120 pages per minute, with the majority of the time being spent on determining the row to split at (i.e. splitNum). I'm sure it can be much faster with a different method of determining splitNum.
I CANNOT ADD AN ADDITIONAL ROW TO THE TABLE FOR THE PURPOSES OF USING "REPEAT HEADER ROWS".
It would violate regulations that are enforced in my industry, and a non-conforming document can be a huge hit to the company and future business
Code:
Sub tblSplit()
Dim timeCheck As Double
Application.ScreenUpdating = False
Application.ActiveWindow.View = wdNormalView
timeCheck = Time
On Error GoTo ErrH
Dim crossRef As Range, delRange As Range, tblR As Range, newTbl As Range
Dim tblNumField As Range, tblNum As String
Set tblNumField = Selection.Tables(1).Range
tblNumField.MoveStart wdParagraph, -1
tblNum = tblNumField.Words(2)
Set crossRef = Selection.Tables(1).Range
Set thisTbl = Selection.Tables(1).Rows(1).Range
Set tblR = Selection.Tables(1).Range
Insert cross-reference to title with style "Caption Cont"
crossRef.Move wdCharacter, -2
crossRef.InsertCrossReference ReferenceType:="Table", ReferenceKind:= _
wdOnlyCaptionText, ReferenceItem:=tblNum, InsertAsHyperlink:=True, _
IncludePosition:=False, SeparateNumbers:=False, SeparatorString:=" "
crossRef.Text = vbCr & " (Cont.)" & vbTab
crossRef.MoveStart wdCharacter, 1
crossRef.Style = "Caption Cont."
crossRef.Collapse wdCollapseStart
crossRef.InsertCrossReference ReferenceType:="Table", ReferenceKind:= _
wdOnlyLabelAndNumber, ReferenceItem:=tblNum, InsertAsHyperlink:=True, _
IncludePosition:=False, SeparateNumbers:=False, SeparatorString:=" "
crossRef.MoveEnd wdParagraph, 1
Delete duplicate title
Set delRange = crossRef.Duplicate
crossRef.MoveEnd wdParagraph, 1
crossRef.Copy
delRange.Text = vbNullString
Find row at which table spans two pages
Dim splitNum As Long, n As Long, i As Long, pageNum As Long
pageNum = tblR.Rows(1).Range.Information(wdActiveEndAdjustedPageNumber)
i = 15
Do
If tblR.Rows(i).Next.Range.Information(wdActiveEndAdjustedPageNumber) <> pageNum Then
splitNum = i
Exit Do
End If
i = i + 1
Loop Until i = 100 'arbitrary cap to prevent infinite loop
n = 1
Split and format
Do
DoEvents
'Split and format
tblR.Tables(n).Split (splitNum)
tblR.Tables(n).Rows.Last.Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
'Paste the stuff
Set newTbl = tblR.Tables(n + 1).Range
newTbl.Move wdParagraph, -2
newTbl.Paste
newTbl.MoveEnd wdParagraph, 1
'Clear excess
newTbl.Paragraphs.Last.Range.Text = vbNullString
'Next
n = n + 1
Loop Until tblR.Tables(n).Rows.Count < splitNum
Restore state, report time, safe-exit and error handler set-up for debugging
Application.ActiveWindow.View = wdPrintView
Application.ScreenUpdating = True
MsgBox "Pages completed: " & n & vbCr & _
"Time (sec): " & DateDiff("s", timeCheck, Time) & vbCr & _
"Seconds per page: " & CDbl(DateDiff("s", timeCheck, Time)) / CDbl(n) & vbCr & _
"Pages per minute: " & n / DateDiff("s", timeCheck, Time) * 60
Exit Sub
ErrH:
Application.ScreenUpdating = True
Err.Raise Err.Number
Stop
End Sub
Here is a workaround that makes it seem as if the paragraph is separate from the table, but it's really the first row. I created a table of data with a couple hundred rows, then inserted a new row on the top of the table. The paragraph goes into this empty row at the top. Assuming the rest of the table has borders enabled, disable the top, left, and right borders for the first row only. Then enable "repeat header row". It looks like this when you're done:
and then the second page:
The fundamental problem you will have with any table-splitting approach is that it doesn't take account of the fact that Word uses the active printer driver to optimise the page layout.
Consequently, you may end up with what appears as the last row on a page when one printer is used ending up at the top of the next page when another printer is used. Alternatively, your headings might end up at the bottom of the page when a another printer is used.
As for your 'Caption'/'Caption Cont' Style machinations, that is all quite unnecessary if you create a full-with row for the caption at the top of the table and mark both the first and second rows as table header rows. Only the entry at the top of the table will appear in the Table of Contents. No code required.
This can be done in a much simpler way by inserting the copy of the table caption in a row at the top of the second part of a split table.
Split the table at the end of the first page as you already do. The rest of the activities now focus on the second part of the table.
For the second part of the table insert a single row at the top of the table.
Make the new single row a repeating table heading.
Paste the copy of the table caption in the row at the top of the second part of the table.
This will achieve the effect you are trying to achieve.
I have an Excel workbook with two dynamic OLE DB queries. I'm having issues with refreshes.
To set things up I have a SQL table-valued function as the source. The data is of the nature of...
SGrp SG_Desc SKU SKU_Desc Server Billed
1 Item 1 111 whatever 15 12
1 Item 2 222 some more 10 9
2 Item 3 333 zzz 10 8
3 Item 4 555 abc 20 18
On the first sheet ("Overall") I have a data connection that summarizes the groups with the command text of dynamically modified with one button.
SELECT SGrp, SG_Desc, SUM(Served) AS Served, SUM(Billed) AS Billed FROM mySQLdb ('8/19/2018','8/25/2018') WHERE SGrp <> '' GROUP BY SGrp, SG_Desc ORDER BY SG_Desc
I then have a cell with a data validation list that selects the group and a button to execute the VBA to dynamically modify the other connection. There's also two cells with the report start & end date for filtering. When I push the "Detail" button it runs the code below.
Private Sub RunDetail_Click()
Dim StartDate As Date
Dim EndDate As Date
Dim SGrp As String
Range("A1").Value = Range("G8").Value2
StartDate = Sheets("Overall").Range("H1").Value
EndDate = Sheets("Overall").Range("H2").Value
SGrp = Sheets("Overall").Range("A1").Value
SGrp = LTrim(RTrim(SGrp))
With ActiveWorkbook.Connections("CJP_DeliveryRecap_Detail").OLEDBConnection
.CommandText = "SELECT SKU, SKU_Desc, Served, Billed FROM mySQLdb ('" & StartDate & "','" & EndDate & "') WHERE SG_Desc='" & SGrp & "'"
' .Refresh
' ActiveWorkbook.Connections("CJP_DeliveryRecap_Detail").Refresh
End With
'RefreshOLEDB
'ThisWorkbook.RefreshAll
ActiveWorkbook.Connections("CJP_DeliveryRecap_Detail").Refresh
'Application.CalculateUntilAsyncQueriesDone
Application.Wait (Now + TimeValue("0:00:03"))
Dim rc As Integer
Dim i As Integer
Worksheets("Detail").Activate
With Worksheets("Detail").Range("CJP_DeliveryRecap_Detail")
rc = .Rows.Count
End With
With Worksheets("Detail").Range("E1048576")
.Select
.End(xlUp).Select
End With
i = Selection.Row
Worksheets("Detail").Range("E5").Select
Worksheets("Detail").Range("E5:G" & i).ClearContents
Worksheets("Detail").Range("E5").Value = 1
Worksheets("Detail").Range("F5").Value = "=+CJP_DeliveryRecap_Detail[#Served]*E5"
Worksheets("Detail").Range("G5").Value = "=+CJP_DeliveryRecap_Detail[#Billed]*E5"
Sheets("Detail").Range("E5:G5").Copy Sheets("Detail").Range("E6:E" & rc + 4)
Sheets("Detail").Range("F1").Value = ("=SUM(F5:F" & rc + 4 & ")")
Sheets("Detail").Range("G1").Value = ("=SUM(G5:G" & rc + 4 & ")")
End Sub
So, what is it doing? The first "strange" thing is I occasionally get errors in the code that I have to continue on. A lot of times, but not all, it hits the Application.Wait line, then the Worksheets("Detail").Activate line, and sometimes the line where I set values or copy data.
There are some comments where I've been testing various refreshes etc. The issue is because while when the code completes it displays the data conn detail correctly but the calculations as to the size of the results is from the prior set. If I click the button a second time then it calculates them correctly. I would of course prefer not to have a arbitrary 3sec delay but simply run the rest of the code after the resultant records have been retrieved.
Where am I going wrong as I've been banging my head against the wall with this. Most of what I do is in Access but Excel was the proper tool in this case.
I just thought of, but not thrilled to, would it work to have a separate sub to handle the record size calcs and cell values clear\set and call that from the button click or would that still not be generated until after the original sub ends.
Thanks in advance,
You need to wait till query is complete before proceeding with calculations.
What you need is to add .BackgroundQuery = False to your connection before .refresh
With ActiveWorkbook.Connections("CJP_DeliveryRecap_Detail").OLEDBConnection
.BackgroundQuery = False
.CommandText = "SELECT SKU, SKU_Desc, Served, Billed FROM mySQLdb ......"
.Refresh
End With
This should help
If the stored procedure being called from Excel does not contain "SET NOCOUNT ON" it will not run properly from Excel. I had the same issue and SET NOCOUNT ON was not included in my stored proc; the second i added it, it worked!
I have to create a text box in MS Access where users are able to see the top 3 records of a particular result set. So even if the query results in 5 records I only want it to display the top 3 records as three textboxes (sometimes the result may also be 1,2 or 0 records).
I took the easy way out and created a new subform which was connected to the parent form using master/child field. The textbox was placed in the details part of the subform and as a recordsource of the subfrom used the following query:
Select top 3 tbl1.column1, tbl1.column2
from tbl1
column1 is the control source for the textbox and column2 is the column I have used for master/child link.
Now the catch is that the query works fine when I use it without top 3. But when I use top 3 the textbox suddenly disappears and the subform is completely blank.
I am not able to identify the cause of the error. My guess is that it has something to do with type of the subform. Not sure.
Is there any other way I can have a text box whose number can vary on the basis of the results?(but limiting the resultset to 3)
Appreciate the help.
Textbox are not meant to hold more than 1 value.
You are trying to assign three results of 2 columns to one textbox(No can do).
Use listbox to populate as you are doing, assigning the query you just wrote in the rowsource of the list(no subforms needed). This way users will see the three records.
You could use a textbox in order to accomplish what you are trying to do. But will require some VBA coding to accomplish this.
Public function CombineValuesForTextBox() as string
Dim rst as dao.recordset
Dim strSQL as string
strSQL = "SELECT TOP 3 tbl1.Column1 as field1, tbl1.Column2 as field2 " & _
"FROM tbl1;"
set rst = currentdb.openrecordset(strsql)
if rst.recordcount = 0 then 'Checks if the recordset has records or not
CombineValuesForTextBox = "No records found"
goto EndCode 'Or replace with what actions to take if no records are found
else
rst.movelast 'Forces the recordset to fully load
rst.movefirst
do while not rst.eof
if CombineValuesForTextBox = "" or CombineValuesForTextBox = empty then
CombineValuesForTextBox = rst![field1] & " - " & rst![Field2]
else
CombineValuesForTextBox = CombineValuesForTextBox & vbcrlf & _
rst![field1] & " - " & rst![Field2]
end if
Loop
end if
rst.close
set rst = nothing
EndCode:
if not rst is nothing then
rst.close
set rst = nothing
end if
end function
Then on your form put in the code (be sure the textbox is unbound...)
me.textbox = CombineValuesForTextBox
I wasn't really sure how to word this question, so I provided steps.
Steps: (VBA-Excel)
Data gets inserted into the database. A query runs to pull all the companies who has violations and insets them into excel.
I then have a loop that takes the value of each company name and insert the cell value (Company name) into another query that retrieves emails.
The problem I have is that some companies have two emails listed. So the db query looks like this:
Company/Email
Microsoft/email1#...
Microsoft/email2#...
Sony/email#...
When the email query is ran using (hope it helps)
n = 1
Do While IsEmpty(Range("A" & n).Value) <> True 'If Cells in Col A is not empty
CSCust = Range("A" & n).Value
qryEmail = "SELECT Email FROM dbo.tblPHEmails WHERE SamplePoint LIKE '" & CSCust & "'"
Set connect = New ADODB.Connection
connect.Open (strConnectStr)
'
'Clean Stream Query
Set recordSetCSEmail = New ADODB.recordSet
recordSetCSEmail.Open qryEmail, connect
Range("C" & n).CopyFromRecordset recordSetCSEmail
n = n + 1
Loop
In Excel, this overwrites one email because it automatically inputs the values on the next row where the next company gets checked (replaced by this company's email). I wish to get the data so where it'll be like:
Company/Email/Email2
Microsoft/email1#.../email2#...
Sony/email#...
I know it's a bit long (I apologize), is this possible? Or, should I go and edit the email list in the DB to allow for each company to have more than one email field?
try adding the maximum number of rows to be copied, using:
Range("C" & n).CopyFromRecordset recordSetCSEmail, 1
I figured out a solution after going over the logic over and over. During the loop, I will just check if a extra email was stored in the cell below (no more than two emails for each company) and move it to the correct location.
One aspect of my project involves comparing the part number entered by the operator to a predetermined list of part numbers in a column in a database. Right now, my program is telling me that every part number entered in the spreadsheet (50+) does not match any in the database, which I've verified to be incorrect. I've checked that both the spreadsheet part number and the database part number are of string datatype. I've doublechecked that my looping logic is good, and to me seems like it should work. To the best of my knowledge there are no hidden characters in either the database cells or in the spreadsheet cells. I'm completely stumped at this point as to why my program doesn't detect any matches between the spreadsheet and the database. Below is the Sub containing the code for checking that the part numbers match:
Sub CheckPN()
'Connect to the E2 database
Call SetPNConnection
'Open a recordset
Set PNRecordset = New ADODB.Recordset
PNRecordset.Open "EstimRpt", PNConnection, adOpenKeyset, adLockOptimistic, adCmdTable
PNSQLCmd = "SELECT DISTINCT [PartNo] FROM EstimRpt;"
'Loop through data, comparing part numbers to E2 database part number records
TotalBadPNCount = 0
With PNRecordset
For DataRowCount = 2 To TrackingLastRow
PNCount = 0
Part_Number = Tracking.Sheets("Operator Data").Range("A" & DataRowCount).Value
'MsgBox "The datatype for " & Part_Number & " is " & VarType(Part_Number) & "."
Do Until .EOF
'MsgBox "The datatype for " & .Fields("PartNo").Value & " is " & VarType(.Fields("PartNo").Value) & "."
If Part_Number = .Fields("PartNo").Value Then
'If .Fields("PartNo").Value = Part_Number Then
MsgBox Part_Number & " is a match."
PNCount = PNCount + 1
End If
.MoveNext
Loop
If PNCount < 1 Then
MsgBox "The P/N " & Part_Number & " entered in cell A" & DataRowCount & " is incorrect. Please correctly enter the P/N and re-run the program."
TotalBadPNCount = TotalBadPNCount + 1
End If
Next DataRowCount
If TotalBadPNCount >= 1 Then
Exit Sub
End If
End With
PNRecordset.Close
Set PNRecordset = Nothing
PNConnection.Close
Set PNConnection = Nothing
End Sub
On a side note, I'd like to have the entire program stop executing if a part number doesn't match, not just the immediate sub. Currently, just this sub exits upon no part number matches.
Thanks for the help on both of these issues.
Jordan
I'd suggest not using a loop to compare records from your user-submitted dataset to your permanent table. Instead, load the user-submitted dataset into a temporary table in your DB, and use SQL to compare the 2 tables.
You can try something along these lines:
'Load spreadsheet into temp table
<your code here>
'open recordset in order to compare PartNos
Dim db As Database
Set db = CurrentDb
Dim rs As Recordset
sSQL = "select count(*) as [count] from temp " _
& " where temp.PartNo not in (select distinct EstimRpt.PartNo from EstimRpt)"
Set rs = db.OpenRecordset(sSQL)
ctRecords = rs![Count]
'if records are found in temp table that do not exist
'in the perm table, then end execution of everything.
if ctRecords > 0 then
End
else
'run the rest of your code
<your code here>
end if
'Drop temp table
<your code here>
I found my problem at long last. The comparing records between database and spreadsheet does work now. I had to make the following changes to my code:
Instead of:
Do Until .EOF
I needed:
Do Until .EOF = True
I also needed to add the following just after the For Loop declaration:
.MoveFirst
Now my code loops correctly.