Macro has stopped working - vba

My wife has a spread sheet at work that has stopped working. You input the data into one tab on a nice easy to use sheet, then press a button and the data is transferred to a table on another sheet. the input tab is called "NCR Report" and the table tab is called "PM2" below is the macro. Any idea why it has stopped working?
Sub Button111_Click()
Dim a As Date
Dim Counter As Integer
Dim Filled As Boolean
Dim ParamOut As String
Dim i As Integer
Dim Reels As String
MsgBox ("Wait...")
'Identify 1st empty row
Counter = 3
While Filled = False
Counter = Counter + 1
a = Worksheets("PM 2").Cells(Counter, 1).Value
If a = 0 Then
Filled = True
Else: Filled = False
End If
Wend
'Shift
Worksheets("PM2").Cells(Counter, 2).Value = Worksheets("NCR Report").Cells(2, 7).Value
'Production date
Worksheets("PM2").Cells(Counter, 1).Value = Worksheets("NCR Report").Cells(3, 7).Value
'Article number
Worksheets("PM2").Cells(Counter, 4).Value = Worksheets("NCR Report").Cells(4, 7).Value
'Total weight
Worksheets("PM2").Cells(Counter, 5).Value = Worksheets("NCR Report").Cells(16, 8).Value
'Parameter out, build the string
ParamOut = ""
For i = 21 To 24
If Worksheets("NCR Report").Cells(i, 2).Text <> "" Then
ParamOut = ParamOut & " " & Worksheets("NCR Report").Cells(i, 2).Text & " " & Worksheets("NCR Report").Cells(i, 5).Text & " " & Worksheets("NCR Report").Cells(i, 9).Text & " " & Worksheets("NCR Report").Cells(i, 10).Text
End If
Next i
Worksheets("PM2").Cells(Counter, 6).Value = ParamOut
'Adjustements
Worksheets("PM2").Cells(Counter, 7).Value = Worksheets("NCR Report").Cells(29, 2).Value
'Reel number
Reels = ""
Reels = Worksheets("NCR Report").Cells(10, 2).Text
For i = 11 To 15
If Worksheets("NCR Report").Cells(i, 2).Value = 0 Then
Else: Reels = Reels & " / " & Worksheets("NCR Report").Cells(i, 2).Text
End If
Next i
Worksheets("PM2").Cells(Counter, 3).Value = Reels
MsgBox ("NCR has been successfully added to the spreadsheet." & vbCrLf & "Don't forget to save this file before quitting and also to block the reels on PLAIN.")
End Sub

You've got inconsistent references to the sheet name.
In one case its:
a = Worksheets("PM 2").Cells(Counter, 1).Value
And later its:
Worksheets("PM2").Cells(Counter, 2).Value = Worksheets("NCR Report").Cells(2, 7).Value
The code needs to match the actual name of the worksheet, either with or without the space

Related

Multiple textbox value to one cell

I have a userform, within the userform there is a frame with 4 textbox, how would I pass the values of those 4 textbox into one cell? separated by comma or space.
I tried doing the following within my submit button.
Dim t As MSForms.Control
For Each t In Me.Frame1.Controls
If TypeOf t Is MSForms.TextBox Then
If IsEmpty(stCode1Box) Then
Exit For
End If
If stCode1Box Is Nothing Then
'Cells(emptyRow, 15).Value = stCode1Box.Value
ElseIf Not IsEmpty(stCode1Box) Then
Cells(emptyRow, 15).Value = stCode1Box.Value
ElseIf stCode2Box Is Nothing Then
'Cells(emptyRow, 15).Value = stCode1Box.Value & ", " & stCode2Box.Value
ElseIf Not IsEmpty(stCode2Box) Then
Cells(emptyRow, 15).Value = stCode1Box.Value & ", " & stCode2Box.Value
ElseIf stCode3Box Is Nothing Then
'Cells(emptyRow, 15).Value = stCode1Box.Value & ", " & stCode2Box.Value & ", " & stCode3Box.Value
ElseIf Not IsEmpty(stCode3Box) Then
Cells(emptyRow, 15).Value = stCode1Box.Value & ", " & stCode2Box.Value & ", " & stCode3Box.Value
ElseIf stCode4Box Is Nothing Then
'Cells(emptyRow, 15).Value = stCode1Box.Value & ", " & stCode2Box.Value & ", " & stCode3Box.Value & ", " & stCode4Box.Value
ElseIf Not IsEmpty(stCode4Box) Then
Cells(emptyRow, 15).Value = stCode1Box.Value & ", " & stCode2Box.Value & ", " & stCode3Box.Value & ", " & stCode4Box.Value
End If
End If
Next t
The result would pop up on that cell, and if more than one textbox had value, this would be separated by a ", " Comma.
Untested:
Dim t As MSForms.Control, v
v = ""
For Each t In Me.Frame1.Controls
If TypeOf t Is MSForms.TextBox Then
v = v & iif(v <> "", "," , "") & Trim(t.Value)
End If
Next t
Cells(emptyRow, 15).Value = v
Try simply
Cells(emptyRow, 15).Value = Cells(emptyRow, 15).Value & "," & stCode1Box.Value
You could loop your controls like you already have but rather than having a series of if...elseif statements you could check if the texbox.value is not "", add the value to an array, then join the array separated by whatever you like.
See my example below which writes your values into cell C5 on Sheet1, assuming your userform has a commandbutton named cmdSubmit (this will work for any number of textboxes):
Example
Private Sub cmdSubmit_Click()
Dim temp As Variant
Dim c As Control
Dim myCount As Long
'0 based array starting with a single element
ReDim temp(0 To 0)
myCount = 0
'Check each control for a textbox
For Each c In Me.Frame1.Controls
If TypeOf c Is MSForms.TextBox Then
'if there is a value in the texbox then assign it to an array
If c.Value <> "" Then
temp(myCount) = c.Value
myCount = myCount + 1
'set upperbound of the array +1 when a new value is found
ReDim Preserve temp(0 To UBound(temp) + 1)
End If
End If
Next c
myCount = 0
'Remove the last array element as it must be blank
ReDim Preserve temp(0 To UBound(temp) - 1)
'Create a string of each value joined with a comma and space
Dim myString As String
myString = Join(temp, ", ")
ThisWorkbook.Sheets(1).Range("C5").Value = myString
End Sub
References
Array Function
Join Function

Dynamic excel hyperlink

Hello at the moment I currently have code that generates a seried of hyperlinks in a table that when clicked reference back to a cell on a different sheet contained in the workbook book. See code below.
Report.Hyperlinks.Add Anchor:=Report.Cells(LineNum, 1), Address:="", SubAddress:="Data!A" & (Counter - 1), TextToDisplay:="Link to Data"
The variable counter is the cell in which the data I am linking to is located and Data is the sheet it is contained in. Report is the worksheet to which I am writing the hyperlinks too.
The issue that I am encountering is that when data is either removed or added in the "Data" sheet the hyperlink in the "report" sheet will then link to the wrong cell thus rendering it useless. So to conclude is their a way to generate a dynamic hyperlink that changes based on edits (only line removals not column removal) to endure the hyperlinks link back to the correct data? Thank you for you help.
Full while loop as requested
DaysInCombo = 0
DaysInYear = DateSerial(YearA + 1, 1, 1) - DateSerial(YearA, 1, 1)
ExtraColNumber = Data.UsedRange.Columns.Count + 1
UltimateCount = Data.UsedRange.Rows.Count
Do While Data.Cells(Counter, 4).Value <> ""
'Check if at new position the address or meter number has changed
If Data.Cells(Counter, 4).Value <> CurrentAddress Or Data.Cells(Counter, 11).Value <> CurrentMeterNumber Then
'check num days to determine if there is an exception to be considered
If DaysInCombo = DaysInYear Then
Debug.Print "Good: " & CurrentAddress
Else
Debug.Print "Bad: " & CurrentAddress & " - " & DaysInCombo & " days - SN: " & CurrentMeterNumber
'compare meter number against the known lists
'if meter exists within the known lists then make note and place into a string
ExceptionStr = ""
ReasonStr = ""
TimeRangeStr = ""
'Data.Cells(Counter, 36).Value
'Compare against Meter Removal List
CheckCounter = 2
Do While MeterRemoval.Cells(CheckCounter, 1).Value <> ""
If CurrentMeterNumber = MeterRemoval.Cells(CheckCounter, 10).Value Or _
Right(CurrentMeterNumber, 8) = MeterInstall.Cells(CheckCounter, 10).Value Or _
(InStr(1, CurrentAddress, MeterRemoval.Cells(CheckCounter, 6).Value, vbTextCompare) = 1 And _
MeterRemoval.Cells(CheckCounter, 6).Value <> "") Then
Debug.Print "Success"
ExceptionStr = ExceptionStr & vbCrLf & "Meter Found on the Meter Removal list"
ReasonStr = ReasonStr & "Removed meter"
End If
CheckCounter = CheckCounter + 1
Loop
'Compare against Meter Install List
CheckCounter = 2
Do While MeterInstall.Cells(CheckCounter, 4).Value <> ""
If CurrentMeterNumber = MeterInstall.Cells(CheckCounter, 4).Value Or _
Right(CurrentMeterNumber, 8) = MeterInstall.Cells(CheckCounter, 4).Value Or _
InStr(1, CurrentAddress, MeterInstall.Cells(CheckCounter, 3).Value & " " & MeterInstall.Cells(CheckCounter, 2).Value, vbTextCompare) = 1 Then
Debug.Print "Success"
ExceptionStr = ExceptionStr & vbCrLf & "New Meter Installation"
ReasonStr = ReasonStr & "New meter"
End If
CheckCounter = CheckCounter + 1
Loop
'Compare against Meter Replace List
CheckCounter = 2
Do While MeterReplace.Cells(CheckCounter, 4).Value <> ""
If CurrentMeterNumber = MeterReplace.Cells(CheckCounter, 4).Value Or _
Right(CurrentMeterNumber, 8) = MeterReplace.Cells(CheckCounter, 4).Value Or _
CurrentMeterNumber = MeterReplace.Cells(CheckCounter, 5).Value Or _
Right(CurrentMeterNumber, 8) = MeterReplace.Cells(CheckCounter, 5).Value Or _
InStr(1, CurrentAddress, MeterReplace.Cells(CheckCounter, 3).Value & " " & MeterReplace.Cells(CheckCounter, 2).Value, vbTextCompare) = 1 Then
Debug.Print "Success"
ExceptionStr = ExceptionStr & vbCrLf & "Replaced Meter"
ReasonStr = ReasonStr & "Replaced meter"
End If
CheckCounter = CheckCounter + 1
Loop
'Compare Address Against the Address change list
CheckCounter = 2
'needs work
Do While AddressChange.Cells(CheckCounter, 1).Value <> ""
If InStr(1, CurrentAddress, AddressChange.Cells(CheckCounter, 1).Value, vbTextCompare) = 1 Or _
(InStr(1, CurrentAddress, AddressChange.Cells(CheckCounter, 2).Value, vbTextCompare) = 1 And _
AddressChange.Cells(CheckCounter, 2).Value <> "") Then
Debug.Print CurrentAddress
Debug.Print AddressChange.Cells(CheckCounter, 1).Value
Debug.Print AddressChange.Cells(CheckCounter, 2).Value
Debug.Print "Success"
ExceptionStr = ExceptionStr & vbCrLf & "The address was changed"
ReasonStr = ReasonStr & "Address change"
End If
CheckCounter = CheckCounter + 1
Loop
'Meter Replace NMOG
CheckCounter = 2
Do While MeterReplaceNMOG.Cells(CheckCounter, 4).Value <> ""
If CurrentMeterNumber = MeterReplaceNMOG.Cells(CheckCounter, 4).Value Or _
Right(CurrentMeterNumber, 8) = MeterReplaceNMOG.Cells(CheckCounter, 4).Value Or _
InStr(1, CurrentAddress, MeterReplaceNMOG.Cells(CheckCounter, 3).Value & " " & MeterReplaceNMOG.Cells(CheckCounter, 2).Value, vbTextCompare) = 1 Then
Debug.Print "Success"
ExceptionStr = ExceptionStr & vbCrLf & "Replaced Meter NMOG"
ReasonStr = ReasonStr & "Replaced meter NMOG"
End If
CheckCounter = CheckCounter + 1
Loop
'Check if an exception was found
ExceptionFound = True
If ExceptionStr = "" Or ReasonStr = "" Then
ExceptionStr = "No Exception reason has been found automatically"
ExceptionFound = False
End If
If DateValue(FirstDateRead) > DateValue(Format(DateSerial(YearA, 1, 1))) Then
ExceptionStr = ExceptionStr & vbCrLf & "Meter Recording Started Mid Year"
TimeRangeStr = TimeRangeStr & "Started Mid Year"
End If
If DateValue(LastDateRead) < DateValue(Format(DateSerial(YearA + 1, 1, 1))) Then
ExceptionStr = ExceptionStr & vbCrLf & "Meter Recording Ended Mid Year"
If TimeRangeStr <> "" Then
TimeRangeStr = TimeRangeStr & " - "
End If
TimeRangeStr = TimeRangeStr & "Ended Mid Year"
End If
ExceptionStr = DaysInCombo & " days: " & vbCrLf & ExceptionStr
'The counter is decremented by 1 due to the logic within the loop
Data.Cells(Counter - 1, ExtraColNumber).Value = ExceptionStr
'Make report
'if expection found, then use one report, else other
If ExceptionFound = True Then
Set Report = Report_Auto
Else
Set Report = Report_Manual
End If
'get last line of report sheet
LineNum = Report.UsedRange.Rows.Count + 1
'copy some relevant details of the location to the report and give it a link back to the location in the data.
Application.ScreenUpdating = False
'Link
Report.Hyperlinks.Add Anchor:=Report.Cells(LineNum, 1), Address:="", SubAddress:="Data!A" & (Counter - 1), TextToDisplay:="Link to Data"
'Address
Report.Cells(LineNum, 2).Value = CurrentAddress
'MeterSN
Report.Cells(LineNum, 3).Value = CurrentMeterNumber
'MeterInstall
Report.Cells(LineNum, 4).Value = Data.Cells(Counter - 1, 13).Value
'FirstDate
Report.Cells(LineNum, 5).NumberFormat = "dd-mmm-yy"
Report.Cells(LineNum, 5).Value = Format(FirstDateBill, "dd-MMM-yy")
'LastDate
Report.Cells(LineNum, 6).NumberFormat = "dd-mmm-yy"
Report.Cells(LineNum, 6).Value = Format(LastDateBill, "dd-MMM-yy")
'FirstDate
Report.Cells(LineNum, 7).NumberFormat = "dd-mmm-yy"
Report.Cells(LineNum, 7).Value = Format(FirstDateRead, "dd-MMM-yy")
'LastDate
Report.Cells(LineNum, 8).NumberFormat = "dd-mmm-yy"
Report.Cells(LineNum, 8).Value = Format(LastDateRead, "dd-MMM-yy")
'ProratedDays
Report.Cells(LineNum, 9).Value = DaysInCombo
'RangeText
Report.Cells(LineNum, 10).Value = TimeRangeStr
'ExceptionText
Report.Cells(LineNum, 11).Value = ReasonStr
Application.ScreenUpdating = True
'clear the report value for the next iteration
Set Report = Nothing
Loop

how to lock in between rows in excel vba

I want to lock the in between row's of excel sheet depending the value of the two column's ,
I have following code with me but it's makes entire sheet protected.
the code is :
there is another problem when the loop goes to else part it throws "unable to set Locked property of the range class" the code is :
Do While xlsht.Cells(i, 1) <> vbNullString
If (CStr(xlsht.Cells(i, 54).Value) <> "" And (CStr(Format(xlsht.Cells(i, 55).Value, "dd-MMM-yyyy")) = CStr(Format(Now, "dd-MMM-yyyy")))) Then
.Cells.Locked = False
.Range("A" & i & " : " & "BH" & i).Cells.Locked = True
.Range("A" & i & " : " & "BH" & i).Interior.Color = RGB(255, 255, 0)
.Protect Password:=admin
Else
.Cells.Locked = False
.Range("A" & i & " : " & "AC" & i).Cells.Locked = True
.Range("AE" & i & " : " & "AT" & i).Cells.Locked = True
.Range("BB" & i & " : " & "BH" & i).Cells.Locked = True
.Protect Password:=admin
End If
i = i + 1
Loop
End With
you may be after something like this:
Dim i As Long
i = 1
With Worksheets("mySheetName") '<--| change "mySheetName" to your actual sheet name
Do While .Cells(i, 1) <> ""
If (.Cells(i, 54).Value = "abc" And .Cells(i, 55).Value = "def") Then Intersect(.Range("A:BH"), .Rows(i)).Locked = True
i = i + 1
Loop
.Protect Password:="admin"
End With
By default, the entire sheet is Locked (property of a Range or Cell).
And you can only Protect an ENTIRE sheet.
So you'll have to unLock the rest of the sheet first!
i = 1
With xlsht
.Unprotect Password:=admin
.Cells.Locked = False
Do While xlsht(i, 1) <> vbNullString
If .Cells(i, 54).Values = "abc" And .Cells(i, 55).Values = "def" Then
'here is checking the column depends the row is get lock or not
.Range("A" & i & ":BH" & i).Cells.Locked = True
i = i + 1
End If
Loop
.Protect Password:=admin
End With 'xlsht
Second question
i = 1
With xlsht
.Unprotect Password:=admin
.Cells.Locked = False
Do While .Cells(i, 1).Value <> vbNullString
If CStr(.Cells(i, 54).Value) <> vbNullString And CDate(.Cells(i, 55).Value) = Date Then
With .Range("A" & i & ":BH" & i)
.Cells.Locked = True
.Interior.Color = RGB(255, 255, 0)
End With '.Range("A" & i & ":BH" & i)
Else
.Range("A" & i & ":AC" & i).Cells.Locked = True
.Range("AE" & i & ":AT" & i).Cells.Locked = True
.Range("BB" & i & ":BH" & i).Cells.Locked = True
End If
i = i + 1
Loop
.Protect Password:=admin
End With 'xlsht

Need to compare 2 excel sheets and create report

I have 2 Excel sheets, I need to take 1 value in Sheet 1, look for it in Sheet 2. If I find it, then I need to make sure that some other values are matching. If yes, I copy the sheet 1 row in a "match" tab.
If not, I copy the row in "mismatch" tab and I need to insert a message that says which value didn't match.
I cannot make it work right now. I think I'm not exiting the loop in the right place. Here is my code. If anybody could help, I would appreciate.
Sub compareAndCopy()
Dim LastRowISINGB As Integer
Dim LastRowISINNR As Integer
Dim lastRowM As Integer
Dim lastRowN As Integer
Dim foundTrue As Boolean
Dim ErrorMsg As String
' stop screen from updating to speed things up
Application.ScreenUpdating = False
'Find the last row for column F and Column B from Sheet 1 and Sheet 2
LastRowISINGB = Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count, "f").End(xlUp).row
LastRowISINNR = Sheets("Sheet2").Cells(Sheets("Sheet2").Rows.Count, "b").End(xlUp).row
'fIND THE LAST ROW OF MATCH AND MISMATCH TAB
lastRowM = Sheets("mismatch").Cells(Sheets("mismatch").Rows.Count, "f").End(xlUp).row + 1
lastRowN = Sheets("match").Cells(Sheets("match").Rows.Count, "f").End(xlUp).row + 1
'ISIN MATCH FIRST
For I = 2 To LastRowISINGB
For J = LastRowISINNR To 2 Step -1
If Sheets("Sheet1").Cells(I, 6).Value = Sheets("Sheet2").Cells(J, 2).Value And _
Worksheets("Sheet1").Range("B" & I).Value = "Y" And _
Worksheets("Sheet2").Range("Z" & J).Value = "" And _
(Worksheets("Sheet1").Range("c" & I).Value = Worksheets("Sheet2").Range("AF" & J).Value Or _
Worksheets("Sheet1").Range("K" & I).Value = Worksheets("Sheet2").Range("K" & J).Value Or _
Worksheets("Sheet1").Range("N" & I).Value = Worksheets("Sheet2").Range("L" & J).Value) Then
Sheets("Sheet1").Rows(I).Copy Destination:=Sheets("match").Rows(lastRowN)
lastRowN = lastRowN + 1
Exit For
ElseIf Sheets("Sheet1").Cells(I, 6).Value = Sheets("Sheet2").Cells(J, 2).Value And _
Worksheets("Sheet1").Range("B" & I).Value = "Y" And _
Worksheets("Sheet2").Range("Z" & J).Value = "" And _
Worksheets("Sheet1").Range("c" & I).Value <> Worksheets("Sheet2").Range("AF" & J).Value And _
Worksheets("Sheet1").Range("K" & I).Value <> Worksheets("Sheet2").Range("K" & J).Value And _
Worksheets("Sheet1").Range("N" & I).Value <> Worksheets("Sheet2").Range("L" & J).Value Then
ErrorMsg = "dates don't match"
ElseIf Sheets("Sheet1").Cells(I, 6).Value = Sheets("Sheet2").Cells(J, 2).Value And _
Worksheets("Sheet1").Range("B" & I).Value <> "Y" Then
ErrorMsg = "B column don't match"
ElseIf Sheets("Sheet1").Cells(I, 6).Value = Sheets("Sheet2").Cells(J, 2).Value And _
Worksheets("Sheet1").Range("B" & I).Value = "Y" And _
Worksheets("Sheet2").Range("Z" & J).Value <> "" Then
ErrorMsg = "Z column don't match"
Else: ErrorMsg = "ISIN don't match"
End If
Next J
Sheets("Sheet1").Rows(I).Copy Destination:=Sheets("mismatch").Rows(lastRowM)
Worksheets("mismatch").Range("S" & lastRowM).Value = ErrorMsg
lastRowM = lastRowM + 1
Next I
' stop screen from updating to speed things up
Application.ScreenUpdating = True
End Sub
First, I think you should add "Exit For" for each clause in If..else method. Otherwise it will lead to the fact that almost of your "miss match" result will be "ISIN don't match".
Second, I think you should set ErrorMsg = "" before For J = LastRowISINNR To 2 Step -1, and have condition ErrorMsg <> "" when you input result in sheet miss match.
Sheets("Sheet1").Rows(I).Copy Destination:=Sheets("mismatch").Rows(lastRowM)
Worksheets("mismatch").Range("S" & lastRowM).Value = ErrorMsg
lastRowM = lastRowM + 1
Otherwise, all your row even match or missmatch will input into miss match sheet.

Vb.net connection timeout while generating excel report

I am trying to generate an excel report using the data from MSSQL. It is perfectly working on my pc(server) and all clients except those PC that has windows 8 installed(MS Office 2010 installed). I tested the program in WinxP/win7 client PC's and both are able to generate the excel report(MS office 2007) installed. Is it possible that the problem is the different version of the MS Office? Here a sample of my code. Again it is working perfectly fine on my server PC and other client PC except that win8 machine.
Private Sub Report_JSIADGTAMKOR()
On Error Resume Next
Dim consigneeName As String
If cmboAccount.Text = "AMKOR" Then
consigneeName = "AMKOR"
ElseIf cmboAccount.Text = "JSI-CIRTEK" Then
consigneeName = "JSI-CIRTEK"
ElseIf cmboAccount.Text = "JSI-LATTICE" Then
consigneeName = "JSI-LATTICE"
Else
consigneeName = "ANALOG DEVICES GEN. TRIAS - JSI"
End If
Wbook = createExcel.Workbooks.Add
Wsheet = Wbook.Worksheets(1)
If Format(dteFrom.Value, "MM-dd-yyyy") = Format(dteTo.Value, "MM-dd-yyyy") Then
DateRange = Format(dteTo.Value, "MM-dd-yyyy")
Else
DateRange = Format(dteFrom.Value, "MM-dd") & " To " & Format(dteTo.Value, "MM-dd-yy")
End If
Wbook.Worksheets(1).Name = cmboAccount.Text & "-SR " + DateRange.ToString
Wsheet.Cells(1, 1).Value = "MAKATI TRANSFORWARDERS CORP."
Wsheet.Cells(1, 1).Font.Bold = True
Wsheet.Cells(1, 1).Font.Size = 10
Wsheet.Cells(3, 1).Value = "Daily Status Report - " & DateRange.ToString
Wsheet.Cells(3, 1).Font.Bold = True
Wsheet.Cells(3, 1).Font.Size = 10
Wsheet.Cells(5, 1).Value = consigneeName
Wsheet.Cells(5, 1).Font.Bold = True
Wsheet.Cells(5, 1).Font.Size = 10
Wsheet.Cells(7, 1).Value = "Prepared by: Jasmin"
Wsheet.Cells(7, 1).Font.Bold = True
Wsheet.Cells(7, 1).Font.Size = 10
Wsheet.Cells(9, 1).Value = "HAWB"
Wsheet.Cells(9, 2).Value = "INVOICE VALUE"
Wsheet.Cells(9, 3).Value = "DUTIABLE VALUE"
Wsheet.Cells(9, 4).Value = "CUSTOMS DUTY"
Wsheet.Cells(9, 5).Value = "LANDED COST"
Wsheet.Cells(9, 6).Value = "ENTRY NO"
Wsheet.Cells(9, 7).Value = "IP NO"
Wsheet.Cells(9, 8).Value = "DESCRIPTION"
Wsheet.Cells(9, 9).Value = "REMARKS"
For Me.itemCounter = 1 To 9
Wsheet.Cells(9, itemCounter).Font.Bold = True
Next itemCounter
rs = New ADODB.Recordset
sql = "Select * From tblDocEntry Where CONVERT(datetime, DateEntry) Between '" & Format(dteFrom.Value, "MM/dd/yyyy") & "' AND '" & Format(dteTo.Value, "MM/dd/yyyy") & "' and ClientCode='" & Trim(cmboAccount.Text) & "' order by DateEntry"
With rs
.Open(sql, cn, CursorTypeEnum.adOpenDynamic, LockTypeEnum.adLockOptimistic)
rowCounter = 10
itemCounter = 1
While .EOF = False
Dim chkBLHAWBno As String
chkBLHAWBno = .Fields("BLHAWBNo").Value
Dim subHAWB As String
subHAWB = chkBLHAWBno.ToString.Substring(0, 3)
If IsExist("tblOmit", "OmitHAWB", subHAWB) Then
Dim len As String = chkBLHAWBno.ToString.Trim.Length
Wsheet.Cells(rowCounter, 3).Value = chkBLHAWBno.ToString.Substring(4, len - 4)
Else
Wsheet.Cells(rowCounter, 3).Value = .Fields("BLHAWBNo").Value
End If
Wsheet.Cells(rowCounter, 1).NumberFormat = "0000"
Wsheet.Cells(rowCounter, 2).Value = .Fields("FMVUSD").Value
Wsheet.Cells(rowCounter, 2).NumberFormat = "0.00"
Wsheet.Cells(rowCounter, 3).Value = .Fields("PESOVALUE").Value
Wsheet.Cells(rowCounter, 3).NumberFormat = "0.00"
Wsheet.Cells(rowCounter, 4).Value = .Fields("DUTYAMOUNT").Value
Wsheet.Cells(rowCounter, 4).NumberFormat = "0.00"
Wsheet.Cells(rowCounter, 5).Value = .Fields("LANDEDCOST").Value
Wsheet.Cells(rowCounter, 5).NumberFormat = "0.00"
Wsheet.Cells(rowCounter, 6).Value = .Fields("ENTRYNO").Value
Wsheet.Cells(rowCounter, 7).Value = .Fields("IPNO").Value
Wsheet.Cells(rowCounter, 8).Value = Trim(.Fields("GoodDesc").Value)
Wsheet.Cells(rowCounter, 9).Value = .Fields("DOCREMARKS").Value
rowCounter = rowCounter + 2
itemCounter = itemCounter + 1
.MoveNext()
End While
.Close()
End With
rs = Nothing
Wsheet.Cells(rowCounter + 1, 1).Value = "Total Number of Entry/ies: " & (itemCounter - 1)
Wsheet.Cells(rowCounter + 2, 1).Value = "Date Printed: " + Format(Now, "MM/dd/yyyy") + " - " + Format(Now, "hh:mm:ss tt")
Wsheet.Cells(rowCounter + 1, 1).Font.Bold = True
Wsheet.Cells(rowCounter + 2, 1).Font.Bold = True
Wsheet.Columns.AutoFit()
Wsheet.Rows.AutoFit()
'Wsheet.Cells.NumberFormat = "0000"
filesavepath = AppPath & "\Status Reports\" & Trim(cmboAccount.Text) & " - Status Report " + DateRange.ToString + ".xls"
Wbook.SaveAs(filesavepath)
Wbook.Close(True)
System.Diagnostics.Process.Start(filesavepath)
Wbook = Nothing
Wsheet = Nothing
MsgBox("Report Successfully Generated", vbOKOnly + vbInformation, "System Alert")
End Sub
The error thrown is something like these:
"Connection Timeout Expired: The timeout period elapsed during the post-login phase. The connection could have timed out while waiting for server to complete the login process and respond. Or it could have timed out while attempting to create multiple active connections."
Any help regarding my problem would be much appreciated
No one can give you exact answer why it happens unless trying it in the hard way.
Generally i suggest you to take more actions to debug it through, to identify:
is it a sql connection problem?
Could it be due to the Win 8 box blocked the sql connection get through? firewall?
what's the size of the expected data from sql? Could it be the Win 8 machine have some anti-virus software scanning the incoming data that slows down the process?
is it due to excel writing process taking too long?
I can see you update excel file cell by cell, actually there are better ways to speed it up significantly, you could ask google for fast writing to excel through interop
data size - could it happen that there are too many rows to write into the file and it takes ages?
You may put more breakpoints or some logging statements to dig out the actual cause, and then work around that.