Allow Blank Entries in Range Excel? - arrays

Below is the code. What I'm confused about is how to get the BuyOne, BuyTwo, BuyThree, BuyFour array (arrBuyer) to allow blank entries. Right now if an entry is blank it'll say it's an invalid entry, whereas I just want it skipped over. In addition, if ALL entries are blank, I want it where the code just assumes the user wants to run every possible entry.
The user enters codes into four specific slots on the left of the page as seen in the image. Currently the code checks a list off to the right of the page to see if values match. How do I go about doing the above?
If Range("reqFrDt") = vbNullString Or IsDate(Range("reqFrDt")) = False Then
MsgBox "From date missing..."
Range("reqFrDt").Select
End
Else
sFrDt = Range("reqFrDt")
End If
If Range("reqToDt") = vbNullString Or IsDate(Range("reqToDt")) = False Then
MsgBox "To date missing or invalid.."
Range("reqToDt").Select
End
Else
sToDt = Range("reqToDt")
End If
lastRow = Range("O" & Rows.Count).End(xlUp).Row
Set rBuyerList = Range("O1:O" & lastRow)
arrBuyer = Array("BuyOne", "BuyTwo", "BuyThree", "BuyFour")
For i = 0 To UBound(arrBuyer)
With Application
chkFind = .IfError(.Match(Range(arrBuyer(i)), Range("O1:O50"), 0), 0)
End With
If Range(arrBuyer(i)) = vbNullString Or chkFind = False Then
MsgBox "Invalid Buyer Code.." & arrBuyer(i)
Range(arrBuyer(i)).Select
End If
Next i
Call runFinished(sFrDt, sToDt, arrBuyer)
Sheets("Main Sheet").Select
MsgBox ("done...")
End Sub
Sub runFinished(sFrDt As String, sToDt As String, arrBuyer As Variant)
Dim SQL As String
' add a new work sheet
ActiveWorkbook.Worksheets.Add
' dispay Criteria
Cells(1, 1) = "Run Date: " & Now()
Call MergeLeft("A1:B1")
Cells(2, 1) = "Criteria:"
Cells(2, 2) = "From " & Range("reqFrDT") & " -To- " & Range("reqToDt")
' SQL
SQL = "select a.StockCode [Finished Part], a.QtyToMake, FQOH,FQOO,/*FQIT,*/FQOA, b.Component [Base Material], CQOH,CQOO,CQIT,CQOA " & _
"from ( " & _
" SELECT StockCode, sum(QtyToMake) QtyToMake " & _
" from [MrpSugJobMaster] " & _
" WHERE 1 = 1 " & _
" AND JobStartDate >= '" & sFrDt & "' " & _
" AND JobStartDate <= '" & sToDt & "' " & _
" AND JobClassification = 'OUTS' " & _
" AND ReqPlnFlag <> 'I' AND Source <> 'E' Group BY StockCode " & _
" ) a " & _
"LEFT JOIN BomStructure b on a.StockCode = b.ParentPart " & _
"LEFT JOIN ( " & _
" select StockCode, sum(QtyOnHand) FQOH, Sum(QtyAllocated) FQOO, Sum(QtyInTransit) FQIT, Sum(QtyOnOrder) FQOA " & _
" from InvWarehouse " & _
" where Warehouse in ('01','DS','RM') " & _
" group by StockCode " & _
") c on a.StockCode = c.StockCode " & _
"LEFT JOIN ( " & _
" select StockCode, sum(QtyOnHand) CQOH, Sum(QtyAllocated) CQOO, Sum(QtyInTransit) CQIT, Sum(QtyOnOrder) CQOA " & _
" from InvWarehouse " & _
" where Warehouse in ('01','DS','RM') " & _
" group by StockCode " & _
") d on b.Component = d.StockCode "
SQL = SQL & _
"LEFT JOIN InvMaster e on a.StockCode = e.StockCode " & _
"WHERE 1 = 1 " & _
"and e.Buyer in ('" & Range(arrBuyer(0)) & "','" & Range(arrBuyer(1)) & "','" & Range(arrBuyer(2)) & "','" & Range(arrBuyer(3)) & "') " & _
"ORDER BY a.StockCode "

Related

Pass Array Into Subroutine for Excel VBA?

I'm trying to pass the results of an array into a subroutine. I have an array that picks up four different Buyer codes from a list. They're labelled as BuyOne, BuyTwo, BuyThree, BuyFour. I'm trying to get the results into the next subroutine, but I'm getting a type mismatch at the subroutine call. Even when I fiddle with it I don't know how to get the results into the subroutine. Can anyone tell me what i'm doing wrong?
Code below:
lastRow = Range("O" & Rows.Count).End(xlUp).Row
Set rBuyerList = Range("O1:O" & lastRow)
arrBuyer = Array("BuyOne", "BuyTwo", "BuyThree", "BuyFour")
For i = 0 To UBound(arrBuyer)
With Application
chkFind = .IfError(.Match(Range(arrBuyer(i)), Range("O1:O50"), 0), 0)
End With
If Range(arrBuyer(i)) = vbNullString Or chkFind = False Then
MsgBox "Invalid Buyer Code.." & arrBuyer(i)
Range(arrBuyer(i)).Select
End If
Next i
Call runFinished(sFrDt, sToDt, arrBuyer())
Sheets("Main Sheet").Select
MsgBox ("done...")
End Sub
Sub runFinished(sFrDt As String, sToDt As String, arrBuyer() As Variant)
Dim SQL As String
' add a new work sheet
ActiveWorkbook.Worksheets.Add
' dispay Criteria
Cells(1, 1) = "Run Date: " & Now()
Call MergeLeft("A1:B1")
Cells(2, 1) = "Criteria:"
Cells(2, 2) = "From " & Range("reqFrDT") & " -To- " & Range("reqToDt")
' SQL
SQL = "select a.StockCode [Finished Part], a.QtyToMake, FQOH,FQOO,/*FQIT,*/FQOA, b.Component [Base Material], CQOH,CQOO,CQIT,CQOA " & _
"from ( " & _
" SELECT StockCode, sum(QtyToMake) QtyToMake " & _
" from [MrpSugJobMaster] " & _
" WHERE 1 = 1 " & _
" AND JobStartDate >= '" & sFrDt & "' " & _
" AND JobStartDate <= '" & sToDt & "' " & _
" AND JobClassification = 'OUTS' " & _
" AND ReqPlnFlag <> 'I' AND Source <> 'E' Group BY StockCode " & _
" ) a " & _
"LEFT JOIN BomStructure b on a.StockCode = b.ParentPart " & _
"LEFT JOIN ( " & _
" select StockCode, sum(QtyOnHand) FQOH, Sum(QtyAllocated) FQOO, Sum(QtyInTransit) FQIT, Sum(QtyOnOrder) FQOA " & _
" from InvWarehouse " & _
" where Warehouse in ('01','DS','RM') " & _
" group by StockCode " & _
") c on a.StockCode = c.StockCode " & _
"LEFT JOIN ( " & _
" select StockCode, sum(QtyOnHand) CQOH, Sum(QtyAllocated) CQOO, Sum(QtyInTransit) CQIT, Sum(QtyOnOrder) CQOA " & _
" from InvWarehouse " & _
" where Warehouse in ('01','DS','RM') " & _
" group by StockCode " & _
") d on b.Component = d.StockCode "
SQL = SQL & _
"LEFT JOIN InvMaster e on a.StockCode = e.StockCode " & _
"WHERE 1 = 1 " & _
"and e.Buyer in ('" & BuyOne & "','" & BuyTwo & "','" & BuyThree & "','" & BuyFour & "') " & _
"ORDER BY a.StockCode "
If you have this line in your code
arrBuyer = Array("BuyOne", "BuyTwo", "BuyThree", "BuyFour")
Proper call should be
Call runFinished(sFrDt, sToDt, arrBuyer)
And proper declaration of the function is
Sub runFinished(sFrDt As String, sToDt As String, arrBuyer As Variant) without ()
Edit (Thanks to #Rory)
Previously stated is true if arrBuyer was not declared as follows: dim arrBuyer() as variant or dim arrBuyer(). On the other hand if declaration was dim arrBuyer() 'as variant OP's code would work w/o any changes.
Final note: I still prefer not using arrBuyer() As Variant in the sub declaration.

SQL Server transaction causes query timeout

I have this VBA code in MS Access (Connect, Exec and Disconnect are my own ADO subs/functions):
Private Sub cmdShipOrder_Click()
Dim intShipmentID As Integer
Dim rsShipment, rsShipmentDetail As Recordset
On Error GoTo ErrHandler
If Me.ReservationStatus <> "ZBOŽÍ KOMPLETNĚ REZERVOVÁNO" Then
MsgBox "Nejprve je nutné do objednávky rezervovat hmotné zboží.", vbCritical + vbOKOnly, "Chyba"
Exit Sub
End If
If MsgBox("Bude vytvořena expedice a celá objednávka bude označena jako expedovaná. Pokračovat?", vbExclamation + vbYesNoCancel, "Upozornění") <> vbYes Then Exit Sub
Connect
Exec "INSERT INTO tbl1Shipments (CustomerID, ShippingMethodID, ShipToID, CarrierID, ShipmentCode, DateShipped) " & _
"VALUES (" & Me.CustomerID & ", " & _
Me.ShippingMethodID & ", " & _
Me.ShipToID & ", " & _
Me.CarrierID & ", " & _
"'" & Year(Date) & "EXP" & Format(DCount("*", "dbo_tbl1Shipments", "ShipmentCode LIKE '%" & Year(Date) & "EXP%'") + 1, "000") & "', " & _
"GETDATE())"
intShipmentID = DMax("ShipmentID", "dbo_tbl1Shipments", "CustomerID=" & Me.CustomerID)
Conn.BeginTrans
Set rsShipment = CurrentDb.OpenRecordset("SELECT * FROM dbo_v_SalesOrderSub WHERE SalesOrderID=" & Me.SalesOrderID)
rsShipment.MoveFirst
Do Until rsShipment.BOF Or rsShipment.EOF
Exec "INSERT INTO tbl1ShipmentDetails (ShipmentID, SalesOrderDetailID, Quantity) " & _
"VALUES (" & intShipmentID & ", " & _
rsShipment("SalesOrderDetailID") & ", " & _
rsShipment("Quantity") & ")"
rsShipment.MoveNext
Loop
Set rsShipmentDetail = CurrentDb.OpenRecordset("SELECT * FROM dbo_v_ShipmentSub WHERE ShipmentID=" & intShipmentID)
rsShipmentDetail.MoveFirst
Do Until rsShipmentDetail.BOF Or rsShipmentDetail.EOF
If rsShipmentDetail("ProductTypeID") <> 3 Then
Exec "UPDATE tbl1Units " & _
"SET ShipmentDetailID=" & rsShipmentDetail("ShipmentDetailID") & " " & _
"WHERE SalesOrderDetailID=" & rsShipmentDetail("SalesOrderDetailID")
End If
rsShipmentDetail.MoveNext
Loop
Conn.CommitTrans
rsShipment.Close
Set rsShipment = Nothing
rsShipmentDetail.Close
Set rsShipmentDetail = Nothing
Disconnect
Exit Sub
ErrHandler:
MsgBox "CHYBA: " & Err.Description
Conn.RollbackTrans
Exec "DELETE FROM tbl1Shipments WHERE ShipmentID=" & intShipmentID
If Not rsShipment Is Nothing Then
rsShipment.Close
Set rsShipment = Nothing
End If
If Not rsShipmentDetail Is Nothing Then
rsShipmentDetail.Close
Set rsShipmentDetail = Nothing
End If
Disconnect
When I run this without Conn.BeginTrans and Conn.CommitTrans, the code works just fine. However when I leave the transaction commands there, I get a "query timeout" error from SQL Server. Specifically on a second cycle in the INSERT INTO tbl1ShipmentDetails statement. Why?

Automation Error when executing SQL Server Script in Excel VBA

I am opening an SQL Server Connection in EXCEL VBA and on the objMyCmd.Execute line when it is using the SQL script I am getting this error message:
"Run-time error '-2147217900 (80040e14)') Automation error"
I have reviewed other SO posts that seem to reference an issue with the connection string itself, but I don't believe that is the issue as I am able to pull the first few variables listed when eliminating the rest of the SQL script.
I have attempted to review the SQL code to see if I am using an incorrect format, or if the language is not written properly and I am not able to determine the issue. I am hoping with some Q & A we may notice something I have missed in how this is written? Please let me know if there is additional information I can provide, below is the code up to the point of error.
Sub SQL_GetAgentChart()
Dim dtDate As Date
Dim myTable As ListObject
Dim DataServer As String
Dim Database As String
Dim constring As String
DataServer = "GLSSQLMADP2"
Database = "PERF_MGMT_BWRSRV_PROD"
constring = "Driver={SQL Server};Server=" & DataServer & "; Database=" & Database & "; Trusted_Connection=yes"
Dim AVStartDate As Date
Dim AVEndDate As Date
Dim RepID As Long
'Declare variables'
Set objMyConn = New ADODB.Connection
Set objMyCmd = New ADODB.Command
Set objMyRecordset = New ADODB.Recordset
Set myTable = Worksheets("Witness").ListObjects("tblWitness")
AVStartDate = DateValue("Mar 01, 2016")
AVEndDate = DateValue("Mar 31, 2016")
RepID = 2040
'Open Connection'
objMyConn.ConnectionString = constring
objMyConn.Open
'Set and Excecute SQL Command'
Set objMyCmd.ActiveConnection = objMyConn
objMyCmd.CommandText = " " & _
"SELECT PERSN_XTRNL_ID_NR, SOURCE, LOGGINGTS, DD7, CUREREASON, CUREDATE, LNSTATUS " & _
"FROM TTB " & _
"WITH INCALL AS (SELECT T.CUREREASON, CUREVALUE " & _
"FROM TTB T " & _
"JOIN PERSONNEL P ON T.PERSONNELID = P.PERSONNELID " & _
"LEFT JOIN CURETRANSLATE C ON T.CUREREASON = C.CUREREASON AND T.LNSTATUS = C.STATUS " & _
"WHERE T.PERSONNELID = " & RepID & " " & _
"AND LOGGINGTS > '" & AVStartDate & "' " & _
"AND LOGGINGTS < '" & AVEndDate + 1 & "' " & _
"AND INCOMING = 1 " & _
"AND DD7 > 0), OUTCALL AS (SELECT T.CUREREASON, CUREVALUE " & _
"FROM TTB T " & _
"JOIN AVAYA A ON T.UID = A.TTBUID " & _
"LEFT JOIN CURETRANSLATE C ON T.CUREREASON = C.CUREREASON AND T.LNSTATUS = C.STATUS " & _
"WHERE PERSONNELID = " & RepID & " " & _
"AND LOGGINGTS > '" & AVStartDate & "' " & _
"AND LOGGINGTS < '" & AVEndDate + 1 & "' " & _
"AND INCOMING = 0 " & _
"AND A.AVAYAGROUP IN ('15', '1A', '1B', '1C', '1D', '1E', '1F', '1G', '1H') " & _
"AND DD7 > 0) "
objMyCmd.CommandType = adCmdText
objMyCmd.Execute

aClassic ASP : How to locate an specific order in array, or record-set. Then move Next or Previous, starting from that order

I have done a bit of work on my code, and still unsure about how some of the code needs to be done in order to work.
So far I got a function named FunctionUp' coded, this is the code that will go in the following sequence:
If array of orders contains:
'A1G722
'A1G723
'A1G724
'A1G725
'A1G726
'A1G727
I added a reference to the current location as a query-string parameter named rowindex, so if the order passed in query-string is 'A1G725', the row index value will be 4, then function code will ideally browse in this sequence: 'A1G725', 'A1G724', 'A1G723', 'A1G722'
The code for the button:
.Write "<input type='submit' name='btnUp' value='Next' class='buttonRight' />"
The code that calls the function:
If Request("btnUp") = "Next" Then Call FuctionUp()
The code for the function:
Function FuctionUp()
Dim objConn
Dim objRS
Dim SQLOrderList
Dim SQLCurrentOrder
Dim currentorder
Dim previousorder
Dim sortby
Dim dtstart
Dim dtend
Dim index
currentorder = Trim(Request.QueryString("order"))
sortby = Request.QueryString("sortby")
currentorder = Request.QueryString("order")
dtstart = Request.QueryString("start")
dtend = Request.QueryString("end")
Set objRS = Server.CreateObject("ADODB.Recordset")
Set objConn = CreateObject("ADODB.Connection")
objConn.Open Application("conn_AWDSTAGE")
objRS.Cursortype = 3
SQLOrderList = "SELECT orderno" & _
" FROM _order" & _
" WHERE order_date >= '" & dtstart & "'" & _
" AND order_date < '" & dtend & "'" & _
" ORDER BY " & sortby
objRS.Open SQLOrderList, objConn
index = CINT(Request.QueryString("rowindex"))
If Not isNumeric(index) Or index = "" Then
index = 0
End If
'Get this to Array.
Dim iArray
Dim i
Dim sizeOfiArray
iArray = objRS.GetRows()
' sample of array contents after sql execution
'A1G722
'A1G723
'A1G724
'A1G725
'A1G726
'A1G727
sizeOfiArray = uBound(iArray) + 1
if not index >= (sizeOfiArray - 1) then previousorder = (index + 1)
If Not previousorder Is Nothing Then
Response.Redirect("~/printpreview.asp?order=" & previousorder(i) &
"&site=" & spiderSiteKey &
"&env=" & strEnv &
"&start=" & CDate(dtstart) &
"&end=" & CDate(dtend) &
"&rowindex=" & (index + 1) &
"&sortby=" & sortby)
Else
Response.Redirect("~/printpreview.asp?order=" & currentOrder.OrderID &
"&site=" & spiderSiteKey &
"&env=" & strEnv &
"&start=" & CDate(dtstart)) &
"&end=" & CDate(dtend) &
"&rowindex=" & (index) &
"&sortby=" & strSortBy &
"&LastRecord=Up")
End If
objRS.Close()
Set objRS = Nothing
objConn.Close()
Set objConn = Nothing
End Function
Wouldn't it be easier simply to get the next or previous orders directly from the database using SQL:
sSQLGetPrevOrder = "SELECT top(1) PREV.* " _
& " FROM [Order] PREV " _
& " JOIN ( " _
& " SELECT " & strOrderBy & " sortvalue, orderno " _
& " FROM Order WHERE orderno='" & strCurrentOrder & "' " _
& " ) CURR " _
& " ON PREV." & strOrderBy & " < CURR.sortvalue " _
& " OR ( PREV." & strOrderBy & " = CURR.sortvalue " _
& " AND PREV.orderno < CURR.orderno ) " _
& " ORDER BY PREV." & strOrderBy & " DESC, PREV.orderno DESC "
sSQLGetNextOrder = "SELECT top(1) NXT.* " _
& " FROM [Order] NXT " _
& " JOIN ( " _
& " SELECT " & strOrderBy & " sortvalue, orderno " _
& " FROM Order WHERE orderno='" & strCurrentOrder & "' " _
& " ) CURR " _
& " ON NXT." & strOrderBy & " > CURR.sortvalue " _
& " OR ( NXT." & strOrderBy & " = CURR.sortvalue " _
& " AND NXT.orderno > CURR.orderno ) " _
& " ORDER BY NXT." & strOrderBy & " ASC, NXT.orderno ASC "
(Apologies if this code has syntax errors, I have not been able to test it)
If orderno is always a number, you could omit the quote marks around strCurrentOrder.

My form freeze when exporting to XML

is this normal? I can't click anything in my form when I'm exporting a data to XML from 14k records? And I think my form freeze. I'm using vb.net in exporting file from database. Hope to hear positive response.
CODE :
Using xmlWriter As XmlWriter = xmlWriter.Create(oFileName, xmlSetting)
xmlWriter.WriteStartDocument()
xmlWriter.WriteStartElement("Products")
xmlWriter.WriteAttributeString("type", "array")
oDotNet.SqlDb.strCommand = "SELECT IsNULL(SuppCatNum, '') [Stock No], " & _
" ItemCode, " & _
" IsNULL(CodeBars, '') [BardCode List], " & _
" IsNULL(FrgnName, '') [FrgnName], " & _
" ItemName, " & _
" IsNULL(InvntryUom, '') [InvntryUom], " & _
" b.ItmsGrpCod [Category Code], " & _
" b.ItmsGrpNam [Category Name], " & _
" a.QryGroup1 [Allow Decimal], " & _
" Vat.Rate, " & _
" a.ManSerNum, " & _
" IsNULL(a.CardCode, '-1') [CardCode]" & _
" FROM OITM a" & _
" INNER JOIN OITB b ON a.ItmsGrpCod = b.ItmsGrpCod " & _
" INNER JOIN OVTG Vat ON a.VatGourpSa = Vat.Code " '& _
'" WHERE ItemCode = 'Davies EL-0020 White'"
ts_Progress.Maximum = oDotNet.SqlDb.Ds.Tables(0).DefaultView.Count
For i As Integer = 0 To oDotNet.SqlDb.Ds.Tables(0).DefaultView.Count - 1
xmlWriter.WriteStartElement("Product")
xmlWriter.WriteElementString("id", -1)
xmlWriter.WriteElementString("stock_no", oDotNet.SqlDb.GetField(i, "Stock No"))
xmlWriter.WriteElementString("reference", oDotNet.SqlDb.GetField(i, "ItemCode"))
xmlWriter.WriteElementString("name", oDotNet.SqlDb.GetField(i, "ItemName"))
xmlWriter.WriteElementString("short_name", oDotNet.SqlDb.GetField(i, "FrgnName"))
xmlWriter.WriteElementString("supplier_code", oDotNet.SqlDb.GetField(i, "CardCode"))
'*BardCode*'
Select Case oType
Case 1
Dim _BardCode As String = Nothing
oSql.strCommand = "SELECT BcdCode FROM OBCD bcd INNER JOIN OUOM uom ON bcd.UomEntry = uom.UomEntry " & _
" WHERE ItemCode = '" & oDotNet.SqlDb.GetField(i, "ItemCode") & "' AND bcd.BcdCode != '" & oDotNet.SqlDb.GetField(i, "BardCode List") & "' " & _
" /*AND uom.UomCode = '" & oDotNet.SqlDb.GetField(i, "InvntryUom") & "'*/ "
If oSql.Ds.Tables(0).DefaultView.Count > 0 Then
For oBardCode As Integer = 0 To oSql.Ds.Tables(0).DefaultView.Count - 1
_BardCode &= oSql.GetField(oBardCode).ToString & ", "
Next
_BardCode = oDotNet.SqlDb.GetField(i, "BardCode List") & ", " & _BardCode.Substring(0, _BardCode.Length - 2)
Else
_BardCode = oDotNet.SqlDb.GetField(i, "BardCode List")
End If
xmlWriter.WriteElementString("barcode_list", _BardCode)
xmlWriter.WriteElementString("category_id", -1)
xmlWriter.WriteElementString("unit_name", oDotNet.SqlDb.GetField(i, "InvntryUom")) 'oDotNet.SqlDb.GetField(i, "InvntryUom"))
xmlWriter.WriteElementString("retail_price", "")
'*WhsCode Here*'
Dim _WhsCode As String = Nothing
oSql.strCommand = "SELECT WhsCode FROM OITW WHERE ItemCode = '" & oDotNet.SqlDb.GetField(i, "ItemCode") & "' "
For oWhsCode As Integer = 0 To oSql.Ds.Tables(0).DefaultView.Count - 1
_WhsCode &= oSql.GetField(oWhsCode).ToString & ", "
Next
_WhsCode = _WhsCode.Substring(0, _WhsCode.Length - 2)
End Select
xmlWriter.WriteEndElement()
ts_Value += 1
ts_Progress.Value = ts_Value
Next
xmlWriter.WriteEndElement()
xmlWriter.WriteEndDocument()
End Using
You could try Application.DoEvents this is a very sloppy but easy fix to your problem. It will allow you to use the form still, but it will be very slow.

Resources