|
Thanks Alan,
But sorry, I'm kind of a novice here; I created the module as in your reply, but what do I do with it? How do I run what's in that module?
I could only go as far as saying "Call module1.Main()" how should I proceed to run what's inside?
Thanks so far..
modified 3-May-13 10:32am.
|
|
|
|
|
Hi guys,
This might be a little tricky, I don't even know if it's possible.
I've got some code working, but to optimize the performance, I'd like to rewrite parts of it to enhance the performance.
The tables that need to be processed start with a merged cell (spanning all columns), but can be interrupted by another row where all cells are merged. The 2nd row always contains the same text but does not have to be processed.
I'm looking for some time now for an answer to the following questions:
* Is there a way to check if a table is uniform from the 3rd row on? Looping works, but it gets slow on long tables, so I want to avoid looping if possible.
* If the table is not uniform, is there a way to know wich rows are merged (also without looping if possible)?
* One column is populated with ID numbers, wich consist of a number, a linebreak (not a paragraph break) and a code. I want to set the font size for the number to 8 and the font size for the code to 1. Is there a way to apply this to the whole column at once instead of looping trough the cells?
If there's no way to avoid looping, it's not too bad. I've got the code working now, using loops, but since it can take over 5 minutes processing a table of say 600 rows (45 pages), I'm just looking for ways to increase performance.
Thanks in advance!
Cheers!
|
|
|
|
|
|
What kind of Word File are we talking about anyway?
if they are docx they migh be stored as a zip file. Than they are just xml files, and then you could do Linq or other things, they might be much faster.
|
|
|
|
|
Too bad... It's RTF... And the processing involves formatting, that's why taking it out of the document isn't really an option. But it's just a performance tweak 
Cheers!
|
|
|
|
|
RTF = Rich Textbox Format?
BTW: it seems all newer formats of Office, that have the x after, like xlsx are stored as xml's in a zip file.
|
|
|
|
|
Indeed, plain Rich Text Format, the one WordPad has used ever since Windows 3.0 Means the file format could well be older than Word itself
The processing involves formatting, so exporting it to another program (like Excel) isn't really an option. I doubt there is a way to avoid the loops.
The macro runs from a userform (just to provide feedback). I start by setting Application.ScreenUpdate = False, and I regulary use Application.ScreenRefresh.
All of my loops end by calling the DoEvents statement. It's just to prevent Word from showing inresponsive. Elsewise, the user might think Word has crashed and force closure of the process. Maybe I used the DoEvents the wrong way...
Cheers!
|
|
|
|
|
Quote: Is there a way to check if a table is uniform from the 3rd row on? Looping works, but it gets slow on long tables, so I want to avoid looping if possible.
It has been a long time since I did Word vba, but I think something like the following should do the trick for this part of your request.
Do note that I did not include any error handling in this.
Private Function TableIsUniformAfterRow(tbl As Table, row As Integer, sourcedoc As Document) As Boolean
Dim app As Application
Set app = sourcedoc.Application
Dim tmpdoc As Document
Set tmpdoc = app.Documents.Add(, , , False)
app.Activate
sourcedoc.Activate
tbl.Select
Selection.Copy
Dim isuni As Boolean
With tmpdoc
.Activate
Selection.Paste
Dim i As Integer
For i = 1 To row
.Tables(1).Rows(1).Delete
Next i
TableIsUniformAfterRow = .Tables(1).Uniform
.Close (False)
End With
End Function
|
|
|
|
|
when i am creating a macro,one or more sheet has been corrupt automatically,it is giving wrong data,i am not understanding the problem.plz help me where i am getting problem.The code is like.
This Code is written in sheet 1,and sheet 2 is for display the data,and in sheet3 is used for transforming data.
Option Explicit
Dim con As New ADODB.Connection
Dim res As New ADODB.Recordset
Dim res1 As New ADODB.Recordset
Dim res2 As New ADODB.Recordset
Dim res3 As New ADODB.Recordset
Dim res4 As New ADODB.Recordset
Dim res5 As New ADODB.Recordset
Dim res6 As New ADODB.Recordset
Dim res7 As New ADODB.Recordset
Dim res8 As New ADODB.Recordset
Dim res9 As New ADODB.Recordset
Dim res10 As New ADODB.Recordset
Dim res11 As New ADODB.Recordset
Dim res12 As New ADODB.Recordset
Dim res13 As New ADODB.Recordset
Dim res14 As New ADODB.Recordset
Dim res15 As New ADODB.Recordset
Dim res16 As New ADODB.Recordset
Dim res17 As New ADODB.Recordset
Dim Filename, mDirName, metal, fnd, CFP, DsgStr As String
Dim sql, sql1, sql2, sql3, sql4, sql5, sql6, sql7, sql8, sql9, sql10, sql11, sql12, sql13, sql14, sql15, sql16, sql17 As String
Dim x, y, z, z1, z2, y1, y2, y3, y4, y5, y6, y7, y8, y9, y10, y11, y12, tmp, DiaQty, count, t, tmp1, p, count1, count2 As Integer
Dim shp As Object
Public Sub clear()
Sheet2.Name = "Sheet2"
For Each shp In Sheet2.Shapes
If shp.Name <> "Picture2" Then shp.Delete
Next
Sheet3.Range("A:I").ClearContents
Sheet2.Range("D39:D48").ClearContents
Sheet2.Range("E39:E48").ClearContents
Sheet2.Range("F39:F48").ClearContents
Sheet2.Range("G39:G48").ClearContents
Sheet2.Range("H39:H48").ClearContents
Sheet2.Range("I39:I48").ClearContents
Sheet2.Range("J39:J48").ClearContents
Sheet2.Range("K39:K48").ClearContents
Sheet2.Range("E49").ClearContents
End Sub
Public Sub transfer()
On Error GoTo errhandler
With con
.ConnectionString = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=usrread;Initial Catalog=Emr;Data Source=MWKPDB;"
.CommandTimeout = 0
.Open
End With
mDirName = ThisWorkbook.Path & "\" & CStr(Sheet1.Range("A2").Text) + CStr(Sheet1.Range("b2").Text) + CStr(Sheet1.Range("c2").Text) + CStr(Sheet1.Range("d2").Text)
Call clear
If Dir(mDirName, vbDirectory) = "" Then
MkDir mDirName
End If
DsgStr = ""
If Sheet1.Range("A2").Text = "QS" Then
DsgStr = "SM"
Else
DsgStr = "DM"
End If
sql = "select omtc,omyy,omchr,omno,odsr,omdt,omcmcd,oddmcd,Omlmgsal,omlmssal,oddmcd,dmctg,pdesc from ordmst inner join orddsg on omtc=odtc and omyy=odyy and omchr=odchr and omno=odno inner join dsgmst on dmcd=oddmcd and dmtctyp='" & DsgStr & "' " & _
" inner join param on pmcd=dmctg and ptyp='dmctg' where omtc='" & Sheet1.Range("A2").Text & "' and omyy='" & Sheet1.Range("b2").Text & "' and omchr='" & Sheet1.Range("c2").Text & "' and omno='" & Sheet1.Range("d2").Text & "' "
res.CursorLocation = adUseClient
res.Open sql, con
Application.ScreenUpdating = False
If res.RecordCount = 0 Then
MsgBox "No Record Found"
con.Close
Set con = Nothing
Exit Sub
Else
For x = 0 To res.RecordCount - 1
Sheet2.Range("D30").Value = res.Fields.Item(7)
Sheet2.Range("D19").Value = res.Fields.Item(12)
InsertPictureInRange "\\mwkpdb\mwpict\" & res.Fields.Item(11) & "\dm 3d " & res.Fields.Item(7) & ".jpg", Sheet2.Range("G11:K11")
Sheet2.Visible = xlSheetVisible
Sheet2.Range("D8").Value = "K P SANGHVI INTL."
Sheet2.Range("F8").Value = "2004554"
Sheet2.Range("D20").Value = "India"
' Sheet2.Range("D41").Value = "India"
' Sheet2.Range("E41").Value = "India"
' Sheet2.Range("F41").Value = "India"
' Sheet2.Range("G41").Value = "India"
Sheet2.Range("D21").Value = "45 days"
Sheet2.Range("G56").Value = "NA"
Sheet2.Range("D41:K41").Value = "India"
Sheet2.Range("G57").Value = "NA"
Sheet2.Range("G58").Value = "NA"
Sheet2.Range("G59").Value = "NA"
Sheet2.Range("G60").Value = "NA"
Sheet2.Range("J56").Value = "NA"
Sheet2.Range("J57").Value = "NA"
Sheet2.Range("J58").Value = "NA"
Sheet2.Range("J59").Value = "NA"
Sheet2.Range("J60").Value = "NA"
Sheet2.Range("D60").Value = "NA"
Sheet2.Range("D59").Value = "NA"
Sheet2.Range("D58").Value = "NA"
Sheet2.Range("D57").Value = "NA"
Sheet2.Range("D64").Value = "NA"
Sheet2.Range("D65").Value = "NA"
Sheet2.Range("D56").Value = "NA"
Sheet2.Range("D62").Value = "0.00"
Sheet2.Range("G63").Value = "0.00"
Sheet2.Range("D54").Value = "Polished"
'sql2 = "SELECT omtc,omyy,omchr,omno,odsr,omdt,drrmctg,drrmsctg,rmdesc,drrmcd,rmcol,drwt," & _
' "dmctg,DRLN1,RMINTQLY," & _
' "(CASE WHEN RMCOL='W' THEN 'WHITE DIAMOND'WHEN RMCOL='-' THEN 'COLOUR DIAMOND' " & _
' "WHEN RMCOL='BL' THEN 'BLACK DIAMOND'WHEN RMCOL='BLE' THEN 'BLUE DIAMOND'" & _
' "WHEN RMCOL='BN' THEN 'BROWN NATTS DIAMOND'WHEN RMCOL='BR' THEN 'BROWN DIAMOND'" & _
' "WHEN RMCOL='WN' THEN 'WHITE NATTS DIAMOND'WHEN RMCOL='Y' THEN 'YELLOW DIAMOND' " & _
' "Else '' END)as 'Stone Color Name',omlmgcst " & _
'"FROM RMMST INNER JOIN DSGRM ON DRRMCTG=RMCTG AND DRRMSCTG=RMSCTG AND DRRMCD=RMCD inner join " & _
' "dsgmst on drtctyp=dmtctyp and drcd=dmcd inner join " & _
' "orddsg on dmcd=oddmcd inner join " & _
' "ordmst on omtc=odtc and omyy=odyy and omchr=odchr and omno=odno " & _
'"WHERE DRTCTYP='DM' AND DRRMCTG='D' AND OMTC='" & Sheet1.Range("A2").Text & "' AND OMYY='" & Sheet1.Range("b2").Text & "' AND OMCHR='" & Sheet1.Range("c2").Text & "' AND OMNO='" & Sheet1.Range("d2").Text & "' AND ODSR=" & res.Fields.Item(4) & " "
'sql2 = "select ortc,oryy,orsr,orno,(CASE WHEN RMCOL='W' THEN 'WHITE DIAMOND'WHEN RMCOL='-' THEN 'COLOUR DIAMOND' WHEN RMCOL='BL' THEN 'BLACK DIAMOND' WHEN RMCOL='BLE' THEN 'BLUE DIAMOND'WHEN RMCOL='BN' THEN 'BROWN NATTS DIAMOND'WHEN RMCOL='BR' THEN 'BROWN DIAMOND' WHEN RMCOL='WN' THEN 'WHITE NATTS DIAMOND'WHEN RMCOL='Y' THEN 'YELLOW DIAMOND' Else '' END)as 'Stone Color Name' from rmmst inner join ordrm on orrmcd=rmcd and orrmctg=rmctg and orrmsctg=rmsctg where oryy='" & Sheet1.Range("b2").Text & "' and orchr='" & Sheet1.Range("c2").Text & "' and orno='" & Sheet1.Range("d2").Text & "' and ortc='" & Sheet1.Range("A2").Text & "' and orrmctg in ('D','C') and orsr=" & res.Fields.Item(4) & ""
sql2 = "SELECT ORTC,ORYY,ORCHR,ORNO,ORSR,OMDT,ORRMCTG,ORRMSCTG,RMDESC,ORRMCD,RMCOL,ORWT,DMCTG,ORLN1,RMINTQLY,(CASE WHEN RMCOL='W' THEN 'WHITE DIAMOND'WHEN RMCOL='-' THEN 'COLOUR DIAMOND'WHEN RMCOL='BL' THEN 'BLACK DIAMOND'WHEN RMCOL='BLE' THEN 'BLUE DIAMOND'WHEN RMCOL='BN' THEN 'BROWN NATTS DIAMOND'WHEN RMCOL='BR' THEN 'BROWN DIAMOND'WHEN RMCOL='WN' THEN 'WHITE NATTS DIAMOND'WHEN RMCOL='Y' THEN 'YELLOW DIAMOND' Else '' END)as 'Stone Color Name' FROM ORDRM JOIN ORDMST ON ORTC=OMTC AND ORYY=OMYY AND ORCHR=OMCHR AND ORNO=OMNO JOIN RMMST ON ORRMCD=RMCD AND ORRMCTG=RMCTG AND ORRMSCTG=RMSCTG JOIN ORDDSG ON ORTC=ODTC AND ORYY=ODYY AND ORCHR=ODCHR AND ORNO=ODNO AND ORSR=ODSR JOIN DSGMST ON ODDMCD=DMCD WHERE ORTC='" & Sheet1.Range("A2").Text & "' AND ORYY='" & Sheet1.Range("b2").Text & "' AND ORCHR='" & Sheet1.Range("c2").Text & "' AND ORNO='" & Sheet1.Range("d2").Text & "' AND ORSR=" & res.Fields.Item(4) & " AND ORRMCTG IN ('C','D')"
res2.CursorLocation = adUseClient
res2.Open sql2, con
If res2.RecordCount = 0 Then
res2.Close
Set res2 = Nothing
Else
For y = 0 To res2.RecordCount - 1
'Sheet2.Range("M46").Value = res2.Fields.Item(15)
Sheet3.Range("A" & 1 + y).Value = res2.Fields.Item(15)
' Sheet2.Range("M50").Value = res2.Fields.Item(13)
'Sheet2.Range("J66").Value = res2.Fields.Item(16)
res2.MoveNext
Next
End If
Sheet3.coltorow
If res2.EOF Then res2.Close
sql3 = "SELECT OMTC,OMYY,OMNO,ODSR,OMCMCD,OMLMGCST,ODSALPRC,ORRMCTG,(CASE WHEN ORRMCTG NOT IN ('D','C') THEN SUM(ORSALVAL) ELSE 0 END) AS 'METAL',(CASE WHEN ORRMCTG IN ('D','C') THEN SUM(ORSETSALVAL) ELSE 0 END) AS 'SETTING' FROM ORDMST INNER JOIN ORDDSG " & _
"ON OMTC=ODTC AND OMYY=ODYY AND OMCHR=ODCHR AND OMNO=ODNO " & _
"INNER JOIN ORDRM ON ODTC=ORTC AND ODYY=ORYY AND ODCHR=ORCHR AND ODNO=ORNO AND ODSR=ORSR " & _
"where omtc='" & Sheet1.Range("A2").Text & "' and omyy='" & Sheet1.Range("b2").Text & "' and omchr='" & Sheet1.Range("c2").Text & "' " & _
"and omno='" & Sheet1.Range("d2").Text & "' AND ODSR=" & res.Fields.Item(4) & " " & _
"GROUP BY OMTC,OMYY,OMNO,ODSR,OMCMCD,OMLMGCST,ODSALPRC,ORRMCTG"
res3.CursorLocation = adUseClient
res3.Open sql3, con
If res3.RecordCount = 0 Then
res3.Close
Set res3 = Nothing
Else
For z = 0 To res3.RecordCount - 1
If res3.Fields.Item(7).Value = "D" Then
Sheet2.Range("J62").Value = res3.Fields.Item(9)
End If
If res3.Fields(7).Value = "G" Then
Sheet2.Range("G64").Value = res3.Fields.Item(8)
End If
res3.MoveNext
Next
End If
If res3.EOF Then res3.Close
sql4 = "SELECT OLTC,OLYY,OLNO,OLSR,OLSRNO,OLMCD,OLQW,SUM(OLSALVAL),odsalprc FROM ORDLAB " & _
"INNER JOIN ORDDSG ON OLTC=ODTC AND OLYY=ODYY AND OLCHR=ODCHR AND OLNO=ODNO AND OLSR=ODSR " & _
"where oltc='" & Sheet1.Range("A2").Text & "' and olyy='" & Sheet1.Range("b2").Text & "' and olchr='" & Sheet1.Range("c2").Text & "' and olno='" & Sheet1.Range("d2").Text & "' AND OLSR=" & res.Fields.Item(4) & " " & _
"GROUP BY OLSR,OLTC,OLYY,OLNO,OLSRNO,OLMCD,olqw,odsalprc "
res4.CursorLocation = adUseClient
res4.Open sql4, con
If res4.RecordCount = 0 Then
res4.Close
Set res4 = Nothing
Else
For z1 = 0 To res4.RecordCount - 1
If res4.Fields.Item(5) = "RHO" Then
Sheet2.Range("J63").Value = res4.Fields.Item(7)
Sheet2.Range("G65").Value = res4.Fields.Item(8)
Sheet2.Range("D66").Value = res4.Fields.Item(8)
End If
res4.MoveNext
Next
End If
If res4.EOF Then res4.Close
sql5 = "select ortc,oryy,orchr,orno,orsr,sum(orsalval),(sum(orwt)-0.02) as 'GrantCaratweight' from ordrm " & _
" where ortc='" & Sheet1.Range("A2").Text & "' and ORRMCTG in ('D','C') AND oryy='" & Sheet1.Range("b2").Text & "' and orchr='" & Sheet1.Range("c2").Text & "' " & _
" and orno='" & Sheet1.Range("d2").Text & "' and orsr='" & res.Fields.Item(4) & "'" & _
" group by ortc,oryy,orchr,orno,orsr"
res5.CursorLocation = adUseClient
res5.Open sql5, con
If res5.RecordCount = 0 Then
res5.Close
Set res5 = Nothing
Else
For z2 = 0 To res5.RecordCount - 1
Sheet2.Range("J64").Value = res5.Fields.Item(5)
Sheet2.Range("D49").Value = res5.Fields.Item(6) & "ct"
res5.MoveNext
Next
End If
If res5.EOF Then res5.Close
sql6 = "select ortc,oryy,orchr,orno,orsr,orrmptr,orqty,orln1,(case when orrmsctg='CHN' THEN 'CHAIN' WHEN ORRMSCTG='LLS' THEN 'LOBSTER LOCK' WHEN ORRMSCTG='RND' THEN 'ROUND' ELSE ORRMSCTG END) AS 'ORRMSCTG',orwt from ordrm where ortc='" & Sheet1.Range("A2").Text & "' and orno='" & Sheet1.Range("d2").Text & "' and orchr='" & Sheet1.Range("c2").Text & "' and oryy='" & Sheet1.Range("b2").Text & "' and orsr='" & res.Fields.Item(4) & "' and orrmctg in ('d','c')"
res6.CursorLocation = adUseClient
res6.Open sql6, con
If res6.RecordCount = 0 Then
res6.Close
Set res6 = Nothing
Else
For y1 = 0 To res6.RecordCount - 1
'Sheet2.Range("M53").Value = res6.Fields.Item(5)
Sheet3.Range("G" & 1 + y1).Value = res6.Fields.Item(5) & "ct"
'Sheet2.Range("M49").Value = res6.Fields.Item(8)
Sheet3.Range("D" & 1 + y1).Value = res6.Fields.Item(8)
'Sheet2.Range("M55").Value = res6.Fields.Item(9) & "ct"
Sheet3.Range("I" & 1 + y1).Value = res6.Fields.Item(9) & "ct"
'Sheet2.Range("M54").Value = res6.Fields.Item(6)
Sheet3.Range("H" & 1 + y1).Value = res6.Fields.Item(6)
If res6.Fields.Item(8) = "RND" Then
Select Case res6.Fields.Item(7)
Case 0.003:
Sheet2.Range("E" & 1 + y1).Value = "0.90mm"
Case 0.03:
Sheet3.Range("E" & 1 + y1).Value = "1.00mm"
Case 0.02:
Sheet3.Range("E" & 1 + y1).Value = "1.10mm"
Case 0.01:
Sheet3.Range("E" & 1 + y1).Value = "1.15mm"
Case 1:
Sheet3.Range("E" & 1 + y1).Value = "1.20mm"
Case 1.5:
Sheet3.Range("E" & 1 + y1).Value = "1.25mm"
Case 2:
Sheet3.Range("E" & 1 + y1).Value = "1.30mm"
Case 2.5:
Sheet3.Range("E" & 1 + y1).Value = "1.35mm"
Case 3:
Sheet3.Range("E" & 1 + y1).Value = "1.40mm"
Case 3.5:
Sheet3.Range("E" & 1 + y1).Value = "1.45mm"
Case 4:
Sheet3.Range("E" & 1 + y1).Value = "1.50mm"
Case 4.5:
Sheet3.Range("E" & 1 + y1).Value = "1.55mm"
Case 5:
Sheet3.Range("E" & 1 + y1).Value = "1.60mm"
Case 5.5:
Sheet3.Range("E" & 1 + y1).Value = "1.70mm"
Case 6:
Sheet3.Range("E" & 1 + y1).Value = "1.80mm"
Case 6.5:
Sheet3.Range("E" & 1 + y1).Value = "1.90mm"
Case 7:
Sheet3.Range("E" & 1 + y1).Value = "2.00mm"
Case 7.5:
Sheet3.Range("E" & 1 + y1).Value = "2.10mm"
Case 8:
Sheet3.Range("E" & 1 + y1).Value = "2.20mm"
Case 8.5:
Sheet3.Range("E" & 1 + y1).Value = "2.30mm"
Case 9:
Sheet3.Range("E" & 1 + y1).Value = "2.40mm"
Case 9.5:
Sheet3.Range("E" & 1 + y1).Value = "2.50mm"
Case 10:
Sheet3.Range("E" & 1 + y1).Value = "2.60mm"
Case 10.5:
Sheet3.Range("E" & 1 + y1).Value = "2.70mm"
Case 11:
Sheet3.Range("E" & 1 + y1).Value = "2.80mm"
Case 11.5:
Sheet3.Range("E" & 1 + y1).Value = "2.90mm"
Case 12:
Sheet3.Range("E" & 1 + y1).Value = "3.00mm"
Case 12.5:
Sheet3.Range("E" & 1 + y1).Value = "3.10mm"
Case 13:
Sheet3.Range("E" & 1 + y1).Value = "3.20mm"
Case 13.5:
Sheet3.Range("E" & 1 + y1).Value = "3.30mm"
Case 14:
Sheet3.Range("E" & 1 + y1).Value = "3.40mm"
Case 14.5:
Sheet3.Range("E" & 1 + y1).Value = "3.50mm"
Case 15:
Sheet3.Range("E" & 1 + y1).Value = "3.60mm"
Case 15.5:
Sheet3.Range("E" & 1 + y1).Value = "3.70mm"
Case Else:
Sheet3.Range("E" & 1 + y1).Value = res6.Fields.Item(7) & "mm"
End Select
Else
Sheet3.Range("E" & 1 + y1).Value = res6.Fields.Item(7) & "mm"
End If
res6.MoveNext
Next
End If
Sheet3.coltorow3
Sheet3.coltorow5
Sheet3.coltorow6
Sheet3.coltorow7
Sheet3.coltorow2
If res6.EOF Then res6.Close
sql7 = "SELECT ORTC,ORYY,ORCHR,ORNO,ORSR,CRCUSTRMCD,(case when crdesc='Round Single cut' then 'single cut' when crdesc='Round Full Cut'then 'full cut' else crdesc end) as 'Crdesc' FROM ORDRM INNER JOIN ORDMST ON ORTC=OMTC AND ORYY=OMYY AND ORCHR=OMCHR AND ORNO=OMNO INNER JOIN " & _
" CUSTRM ON CROURRMCD=ORRMCD WHERE CRCD=OMCMCD AND ortc='" & Sheet1.Range("A2").Text & "' and orno='" & Sheet1.Range("d2").Text & "' and orchr='" & Sheet1.Range("c2").Text & "' and oryy='" & Sheet1.Range("b2").Text & "' and orsr=" & res.Fields.Item(4) & " " & _
" and orrmctg in ('d','c')"
res7.CursorLocation = adUseClient
res7.Open sql7, con
If res7.RecordCount = 0 Then
res7.Close
Set res7 = Nothing
Else
For y2 = 0 To res7.RecordCount - 1
Sheet3.Range("F" & 1 + y2).Value = res7.Fields.Item(5)
'Sheet2.Range("M47").Value = res7.Fields.Item(6)
Sheet3.Range("B" & 1 + y2).Value = res7.Fields.Item(6)
res7.MoveNext
Next
End If
Sheet3.coltorow4
Sheet3.Coltorow1
If res7.EOF Then res7.Close
sql8 = "select OLTC,OLYY,OLCHR,OLNO,OLSR,(CASE WHEN OLMCD='RHO' THEN 'Rhodium Plate' ELSE '' END) AS 'OLMCD' from ordlab where oltc='" & Sheet1.Range("A2").Text & "' and olyy='" & Sheet1.Range("b2").Text & "'and olchr='" & Sheet1.Range("c2").Text & "' and olno='" & Sheet1.Range("d2").Text & "' and olsr=" & res.Fields.Item(4) & " and olmcd='RHO'"
res8.CursorLocation = adUseClient
res8.Open sql8, con
If res8.RecordCount = 0 Then
res8.Close
Set res8 = Nothing
Else
For y3 = 0 To res8.RecordCount - 1
Sheet2.Range("D53").Value = res8.Fields.Item(5)
res8.MoveNext
Next
End If
If res8.EOF Then res8.Close
sql9 = "SELECT ODTC,ODNO,ODSR,ODDMCOL,PMCD,PDESC FROM ORDDSG INNER JOIN PARAM ON PMCD=ODDMCOL WHERE PTYP='DMCOL' AND ODTC='" & Sheet1.Range("A2").Text & "' AND ODYY='" & Sheet1.Range("b2").Text & "' AND ODCHR='" & Sheet1.Range("c2").Text & "' AND ODNO='" & Sheet1.Range("d2").Text & "' and ODSR='" & res.Fields.Item(4) & "'"
res9.CursorLocation = adUseClient
res9.Open sql9, con
If res9.RecordCount = 0 Then
res9.Close
Set res9 = Nothing
Else
For y4 = 0 To res9.RecordCount - 1
Sheet2.Range("D51").Value = res9.Fields.Item(5)
Sheet2.Range("D54").Value = "Polished"
res9.MoveNext
Next
End If
If res9.EOF Then res9.Close
sql10 = "select cmcurcd from custmst where cmcd='kp029'"
res10.CursorLocation = adUseClient
res10.Open sql10, con
If res10.RecordCount = 0 Then
res10.Close
Set res10 = Nothing
Else
For y5 = 0 To res10.RecordCount - 1
Sheet2.Range("J61").Value = res10.Fields.Item(0)
res10.MoveNext
Next
End If
If res10.EOF Then res10.Close
'written by saurabh sharma for weight of metal on 20/4/13
sql11 = "select round((sum(orwt)*0.90),3) as 'weightofmetal' from ordrm where ortc='" & Sheet1.Range("A2").Text & "' and orno='" & Sheet1.Range("d2").Text & "' and ORCHR='" & Sheet1.Range("c2").Text & "' AND ORYY='" & Sheet1.Range("b2").Text & "' and orsr='" & res.Fields.Item(4) & "'AND ORRMCTG NOT IN ('D','C')"
res11.CursorLocation = adUseClient
res11.Open sql11, con
If res11.RecordCount = 0 Then
res11.Close
Set res11 = Nothing
Else
For y6 = 0 To res11.RecordCount - 1
Sheet2.Range("D52").Value = res11.Fields.Item(0) & "g"
res11.MoveNext
Next
End If
If res11.EOF Then res11.Close
'End
sql12 = "select round((Sum(B.OrPrdWt/(Case When B.OrRmCtg in ('D','C') Then 5 Else 1 End))*0.90),3) from ordrm as b where ortc='" & Sheet1.Range("A2").Text & "' and orno='" & Sheet1.Range("d2").Text & "' and ORCHR='" & Sheet1.Range("c2").Text & "' AND ORYY='" & Sheet1.Range("b2").Text & "' and orsr='" & res.Fields.Item(4) & "'"
res12.CursorLocation = adUseClient
res12.Open sql12, con
If res12.RecordCount = 0 Then
res12.Close
Set res12 = Nothing
Else
For y7 = 0 To res12.RecordCount - 1
Sheet2.Range("D27").Value = res12.Fields.Item(0)
res12.MoveNext
Next
End If
If res12.EOF Then res12.Close
sql13 = "SELECT OLTC,OLYY,OLCHR,OLNO,OLSR,OLMCD,OLSALVAL FROM ordlab where oltc='" & Sheet1.Range("A2").Text & "' and olyy='" & Sheet1.Range("b2").Text & "' and olchr='" & Sheet1.Range("c2").Text & "' and olno='" & Sheet1.Range("d2").Text & "' and olsr='" & res.Fields.Item(4) & "' and olmcd in ('FND')"
res13.CursorLocation = adUseClient
res13.Open sql13, con
If res13.RecordCount = 0 Then
Sheet2.Range("D63").Value = "0.00"
' res13.Close
'Set res13 = Nothing
Else
For y8 = 0 To res13.RecordCount - 1
Sheet2.Range("D63").Value = res13.Fields.Item(6)
res13.MoveNext
Next
End If
If res13.EOF Then res13.Close
sql14 = "select DISTINCT len(oddmcol) AS 'LENODDMCOL',oddmcol,ORRMCTG,ODKT,PMCD,PDESC,(ODKT +' '+case when len(oddmcol)=1 then Pdesc when len(oddmcol)=2 then 'Two Tone' when len(oddmcol)=3 then 'Tri-Casted' else '' end + ' ' + case when orrmctg='D' then 'Diamond' end) as 'Breif Desc' FROM ORDDSG INNER JOIN PARAM ON PMCD=ODDMCOL INNER JOIN ORDRM ON ORTC=ODTC AND ORYY=ODYY AND ORCHR=ODCHR AND ORNO=ODNO AND ODSR=ORSR WHERE PTYP='DMCOL' AND ODTC='" & Sheet1.Range("A2").Text & "' AND ODYY='" & Sheet1.Range("b2").Text & "' AND ODCHR='" & Sheet1.Range("c2").Text & "' AND ODNO='" & Sheet1.Range("d2").Text & "' and ODSR=" & res.Fields.Item(4) & " and orrmctg in ('D')"
res14.CursorLocation = adUseClient
res14.Open sql14, con
If res14.RecordCount = 0 Then
res14.Close
Set res14 = Nothing
Else
For y9 = 0 To res14.RecordCount - 1
Sheet2.Range("D18").Value = res14.Fields.Item(6) & " " & res.Fields.Item(12)
res14.MoveNext
Next
End If
If res14.EOF Then res14.Close
sql15 = "SELECT oltc,olyy,olchr,olno,olsr,olsrno,olscd,pdesc,(case when pscd in ('pst','PST08','PST09','PST10','PST14','PST18','PST925') then 'Click Post' when pscd in ('PSBF08','PSBF09','PSBF10','PSBF14','PSBF18','PSBF925') then 'Post and Butterfly' else 'NA' end) as [desc] FROM ordlab inner join param on olmcd=pmcd and olscd=pscd WHERE OlTC='" & Sheet1.Range("A2").Text & "' AND OlYY='" & Sheet1.Range("b2").Text & "' AND OlCHR='" & Sheet1.Range("c2").Text & "' AND OlNO='" & Sheet1.Range("d2").Text & "' AND OlSR=" & res.Fields.Item(4) & " and ptyp='labscd' and olmcd='FND'"
res15.CursorLocation = adUseClient
res15.Open sql15, con
If res15.RecordCount = 0 Then
Sheet2.Range("D56").Value = "NA"
'res15.Close
'Set res15 = Nothing
Else
For y10 = 0 To res15.RecordCount - 1
Sheet2.Range("D56").Value = res15.Fields.Item(8)
res15.MoveNext
Next
End If
If res15.EOF Then res15.Close
sql16 = "select omtc,omyy,omchr,omno,omcmcd,omlmgcst from ordmst where omtc='" & Sheet1.Range("A2").Text & "' and omyy='" & Sheet1.Range("b2").Text & "' and omchr='" & Sheet1.Range("c2").Text & "' and omno='" & Sheet1.Range("d2").Text & "'"
res16.CursorLocation = adUseClient
res16.Open sql16, con
If res16.RecordCount = 0 Then
res16.Close
Set res16 = Nothing
Else
For y9 = 0 To res16.RecordCount - 1
Sheet2.Range("J66").Value = res16.Fields.Item(5)
res16.MoveNext
Next
End If
If res16.EOF Then res16.Close
sql17 = "SELECT OLTC,OLYY,OLCHR,OLNO,OLSR,SUM(OLSALVAL) FROM ORDLAB WHERE OLTC='" & Sheet1.Range("A2").Text & "' AND OLYY='" & Sheet1.Range("b2").Text & "' AND OLCHR='" & Sheet1.Range("c2").Text & "' AND OLNO='" & Sheet1.Range("d2").Text & "' AND OLSR=" & res.Fields.Item(4) & " AND OLMCD='CFP' GROUP BY OLTC,OLYY,OLCHR,OLNO,OLSR"
res17.CursorLocation = adUseClient
res17.Open sql17, con
If res17.RecordCount = 0 Then
res17.Close
Set res17 = Nothing
Else
For y12 = 0 To res17.RecordCount - 1
Sheet2.Range("G62").Value = res17.Fields.Item(5)
res17.MoveNext
Next
End If
If res17.EOF Then res17.Close
Sheet2.Name = res.Fields.Item("ODDMCD")
Sheet2.Copy
Sheet2.Visible = xlSheetVeryHidden
Filename = mDirName & "\" & res.Fields.Item(7) & "_" & res.Fields.Item(4)
Call Application.ActiveWorkbook.SaveAs(Filename & ".xls")
ActiveWorkbook.Close
res.MoveNext
If res.EOF Then res.Close
Call clear
Next
End If
Exit Sub
errhandler:
If Err.Number = 1004 Then
Resume Next
Else
MsgBox Err.Description
End If
con.Close
Set con = Nothing
End Sub
Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
Set p = Sheet2.Pictures.Insert(PictureFileName)
' determine positions
With TargetCells
t = .Top
l = .Left
w = .Offset(0, .Columns.count).Left - .Left
h = .Offset(.Rows.count, 0).Top - .Top
End With
' position picture
With p
.Top = t + 15
.Left = l + 50
.Width = w - 200
'.Height = h + 255
.Height = h + 265
End With
Set p = Nothing
End Sub
-------------------++++++-----------------------
Sheet3 code
Public Sub coltorow()
Dim rng As Range
Dim i As Long
Dim lastrow As Long
lastrow = Cells(Rows.count, 1).End(xlUp).Row
Set rng = Range(Cells(1, "A"), Cells(lastrow, "A")).SpecialCells(xlCellTypeConstants)
'Sheet1.Columns("D:Z").ColumnWidth = 21
For i = 1 To rng.Areas.count
Sheet2.Cells(i + 38, "D").Resize(1, rng.Areas(i).count).Value = Application.WorksheetFunction.Transpose(rng.Areas(i))
'Sheet2.Cells(i + 45, "W").Resize(1, rng.Areas(i).Count).Value = Application.WorksheetFunction.Transpose(rng.Areas(i))
Next i
End Sub
Public Sub Coltorow1()
Dim rng As Range
Dim i As Long
Dim lastrow As Long
lastrow = Cells(Rows.count, 1).End(xlUp).Row
Set rng = Range(Cells(1, "B"), Cells(lastrow, "B")).SpecialCells(xlCellTypeConstants)
'Sheet1.Columns("D:Z").ColumnWidth = 21
For i = 1 To rng.Areas.count
Sheet2.Cells(i + 39, "D").Resize(1, rng.Areas(i).count).Value = Application.WorksheetFunction.Transpose(rng.Areas(i))
'Sheet2.Cells(i + 45, "W").Resize(1, rng.Areas(i).Count).Value = Application.WorksheetFunction.Transpose(rng.Areas(i))
Next i
End Sub
Public Sub coltorow2()
Dim rng As Range
Dim i As Long
Dim lastrow As Long
lastrow = Cells(Rows.count, 1).End(xlUp).Row
Set rng = Range(Cells(1, "D"), Cells(lastrow, "D")).SpecialCells(xlCellTypeConstants)
'Sheet1.Columns("D:Z").ColumnWidth = 21
For i = 1 To rng.Areas.count
Sheet2.Cells(i + 41, "D").Resize(1, rng.Areas(i).count).Value = Application.WorksheetFunction.Transpose(rng.Areas(i))
'Sheet2.Cells(i + 45, "W").Resize(1, rng.Areas(i).Count).Value = Application.WorksheetFunction.Transpose(rng.Areas(i))
Next i
End Sub
Public Sub coltorow3()
Dim rng As Range
Dim i As Long
Dim lastrow As Long
lastrow = Cells(Rows.count, 1).End(xlUp).Row
Set rng = Range(Cells(1, "E"), Cells(lastrow, "E")).SpecialCells(xlCellTypeConstants)
'Sheet1.Columns("D:Z").ColumnWidth = 21
For i = 1 To rng.Areas.count
Sheet2.Cells(i + 42, "D").Resize(1, rng.Areas(i).count).Value = Application.WorksheetFunction.Transpose(rng.Areas(i))
'Sheet2.Cells(i + 45, "W").Resize(1, rng.Areas(i).Count).Value = Application.WorksheetFunction.Transpose(rng.Areas(i))
Next i
End Sub
Public Sub coltorow4()
Dim rng As Range
Dim i As Long
Dim lastrow As Long
lastrow = Cells(Rows.count, 1).End(xlUp).Row
Set rng = Range(Cells(1, "F"), Cells(lastrow, "F")).SpecialCells(xlCellTypeConstants)
'Sheet1.Columns("D:Z").ColumnWidth = 21
For i = 1 To rng.Areas.count
Sheet2.Cells(i + 43, "D").Resize(1, rng.Areas(i).count).Value = Application.WorksheetFunction.Transpose(rng.Areas(i))
'Sheet2.Cells(i + 45, "W").Resize(1, rng.Areas(i).Count).Value = Application.WorksheetFunction.Transpose(rng.Areas(i))
Next i
End Sub
Public Sub coltorow5()
Dim rng As Range
Dim i As Long
Dim lastrow As Long
lastrow = Cells(Rows.count, 1).End(xlUp).Row
Set rng = Range(Cells(1, "G"), Cells(lastrow, "G")).SpecialCells(xlCellTypeConstants)
'Sheet1.Columns("D:Z").ColumnWidth = 21
For i = 1 To rng.Areas.count
Sheet2.Cells(i + 45, "D").Resize(1, rng.Areas(i).count).Value = Application.WorksheetFunction.Transpose(rng.Areas(i))
'Sheet2.Cells(i + 45, "W").Resize(1, rng.Areas(i).Count).Value = Application.WorksheetFunction.Transpose(rng.Areas(i))
Next i
End Sub
Public Sub coltorow6()
Dim rng As Range
Dim i As Long
Dim lastrow As Long
lastrow = Cells(Rows.count, 1).End(xlUp).Row
Set rng = Range(Cells(1, "H"), Cells(lastrow, "H")).SpecialCells(xlCellTypeConstants)
'Sheet1.Columns("D:Z").ColumnWidth = 21
For i = 1 To rng.Areas.count
Sheet2.Cells(i + 46, "D").Resize(1, rng.Areas(i).count).Value = Application.WorksheetFunction.Transpose(rng.Areas(i))
'Sheet2.Cells(i + 45, "W").Resize(1, rng.Areas(i).Count).Value = Application.WorksheetFunction.Transpose(rng.Areas(i))
Next i
End Sub
Public Sub coltorow7()
Dim rng As Range
Dim i As Long
Dim lastrow As Long
lastrow = Cells(Rows.count, 1).End(xlUp).Row
Set rng = Range(Cells(1, "I"), Cells(lastrow, "I")).SpecialCells(xlCellTypeConstants)
'Sheet1.Columns("D:Z").ColumnWidth = 21
For i = 1 To rng.Areas.count
Sheet2.Cells(i + 47, "D").Resize(1, rng.Areas(i).count).Value = Application.WorksheetFunction.Transpose(rng.Areas(i))
'Sheet2.Cells(i + 45, "W").Resize(1, rng.Areas(i).Count).Value = Application.WorksheetFunction.Transpose(rng.Areas(i))
Next i
End Sub
----------++++++++++----------------------
Sheet3 code
Public Sub coltorow()
Dim rng As Range
Dim i As Long
Dim lastrow As Long
lastrow = Cells(Rows.count, 1).End(xlUp).Row
Set rng = Range(Cells(1, "A"), Cells(lastrow, "A")).SpecialCells(xlCellTypeConstants)
For i = 1 To rng.Areas.count
Sheet2.Cells(i + 38, "D").Resize(1, rng.Areas(i).count).Value = Application.WorksheetFunction.Transpose(rng.Areas(i))
Next i
End Sub
Public Sub Coltorow1()
Dim rng As Range
Dim i As Long
Dim lastrow As Long
lastrow = Cells(Rows.count, 1).End(xlUp).Row
Set rng = Range(Cells(1, "B"), Cells(lastrow, "B")).SpecialCells(xlCellTypeConstants)
For i = 1 To rng.Areas.count
Sheet2.Cells(i + 39, "D").Resize(1, rng.Areas(i).count).Value = Application.WorksheetFunction.Transpose(rng.Areas(i))
Next i
End Sub
Public Sub coltorow2()
Dim rng As Range
Dim i As Long
Dim lastrow As Long
lastrow = Cells(Rows.count, 1).End(xlUp).Row
Set rng = Range(Cells(1, "D"), Cells(lastrow, "D")).SpecialCells(xlCellTypeConstants)
For i = 1 To rng.Areas.count
Sheet2.Cells(i + 41, "D").Resize(1, rng.Areas(i).count).Value = Application.WorksheetFunction.Transpose(rng.Areas(i))
Next i
End Sub
Public Sub coltorow3()
Dim rng As Range
Dim i As Long
Dim lastrow As Long
lastrow = Cells(Rows.count, 1).End(xlUp).Row
Set rng = Range(Cells(1, "E"), Cells(lastrow, "E")).SpecialCells(xlCellTypeConstants)
For i = 1 To rng.Areas.count
Sheet2.Cells(i + 42, "D").Resize(1, rng.Areas(i).count).Value = Application.WorksheetFunction.Transpose(rng.Areas(i))
Next i
End Sub
Public Sub coltorow4()
Dim rng As Range
Dim i As Long
Dim lastrow As Long
lastrow = Cells(Rows.count, 1).End(xlUp).Row
Set rng = Range(Cells(1, "F"), Cells(lastrow, "F")).SpecialCells(xlCellTypeConstants)
For i = 1 To rng.Areas.count
Sheet2.Cells(i + 43, "D").Resize(1, rng.Areas(i).count).Value = Application.WorksheetFunction.Transpose(rng.Areas(i))
Next i
End Sub
Public Sub coltorow5()
Dim rng As Range
Dim i As Long
Dim lastrow As Long
lastrow = Cells(Rows.count, 1).End(xlUp).Row
Set rng = Range(Cells(1, "G"), Cells(lastrow, "G")).SpecialCells(xlCellTypeConstants)
For i = 1 To rng.Areas.count
Sheet2.Cells(i + 45, "D").Resize(1, rng.Areas(i).count).Value = Application.WorksheetFunction.Transpose(rng.Areas(i))
Next i
End Sub
Public Sub coltorow6()
Dim rng As Range
Dim i As Long
Dim lastrow As Long
lastrow = Cells(Rows.count, 1).End(xlUp).Row
Set rng = Range(Cells(1, "H"), Cells(lastrow, "H")).SpecialCells(xlCellTypeConstants)
For i = 1 To rng.Areas.count
Sheet2.Cells(i + 46, "D").Resize(1, rng.Areas(i).count).Value = Application.WorksheetFunction.Transpose(rng.Areas(i))
Next i
End Sub
Public Sub coltorow7()
Dim rng As Range
Dim i As Long
Dim lastrow As Long
lastrow = Cells(Rows.count, 1).End(xlUp).Row
Set rng = Range(Cells(1, "I"), Cells(lastrow, "I")).SpecialCells(xlCellTypeConstants)
For i = 1 To rng.Areas.count
Sheet2.Cells(i + 47, "D").Resize(1, rng.Areas(i).count).Value = Application.WorksheetFunction.Transpose(rng.Areas(i))
Next i
End Sub
|
|
|
|
|
Hi,
1 but your code between pre tags
2 move some of your code into a module
3 split your subs into smaller ones
4 I see a lot of this:
For i = 1 To rng.Areas.count
Sheet2.Cells(i + 38, "D").Resize(1, rng.Areas(i).count).Value = Application.WorksheetFunction.Transpose(rng.Areas(i))
Next i
So re-use your code and create other subs and call them with a parameter
once you have don this maybe your problem is solved. Remember each module form or sheet has a max of 64K
Jan
|
|
|
|
|
There is simply too much information here, scale your problem down were you only include code that is relevant to the issue. I dont think people are going to debug your code for you so...
|
|
|
|
|
How can change Button Label value Every Time when i start Virtual Keyboard, Means ,if 1st time Button1=''a'' then next login time Button1 = " any Alphabet "...is this Possible through Probability Distribution & Counter...?
|
|
|
|
|
You have also posted this question in Java forum. 
Well which language is it, a VB or Java question?
|
|
|
|
|
Give me Solution..in JAVA, VB, NetBeans solution, Dot Net
|
|
|
|
|
Which? Please don't just dump in multiple forums and demand a solution. Choose one forum and explain your problem clearly.
Use the best guess
|
|
|
|
|
Try to Give me Solution..in JAVA if its not possible in Java
then
try in VB or NetBeans solu Sothat i can use only Method from any other Languages or Plateform.
|
|
|
|
|
Make up your mind which one you want, and explain your problem clearly. Your question, as it stands, makes no sense.
Use the best guess
|
|
|
|
|
I have SQL that is returning 24 rows in SQLPlus however when I run the same query in VS2010 using Provider=OraOLEDB.Oracle its doesn't return any rows. I am using a LIKE operator with to_date. Any suggestions? Is it the provider I am using the problem?
See example
select level from testTable where dTime LIKE to_date('3/27/2013','MM/DD/YYYY') and station = '019654' order by dTime
I did try it with '%3/27/2013%'
|
|
|
|
|
Have you tried running the query in Oracle directly?
Every day, thousands of innocent plants are killed by vegetarians.
Help end the violence EAT BACON
|
|
|
|
|
yes and it works perfectly. I am using VS2010 if that makes a difference.
|
|
|
|
|
What's the code you're using to execute the query?
"These people looked deep within my soul and assigned me a number based on the order in which I joined."
- Homer
|
|
|
|
|
Dim dsFred = New DataSet
conn = New OleDbConnection("Provider=OraOLEDB.Oracle;User ID=test;Password=testPass;Data Source=ARC")
sql = "select level from testTable where dTime LIKE to_date('3/27/2013','MM/DD/YYYY') and station = '019654' order by dTime"
myCommand = New OleDbDataAdapter(sql, conn)
myCommand.Fill(dsFred, "fred")
Dim fred As Integer = dsFred.Tables("fred").Rows.Count
|
|
|
|
|
I notice that you are using the OleDb namespace data objects and not the OracleClient objects.
Try adding a reference to System.Data.OracleClient.dll and use the OracleClient.OracleConnection, OracleClient.OracleCommand, and OracleClient.OracleDataAdapter objects.
|
|
|
|
|
That's a funny Oracle feature. LIKE with a date/datetime field does not make sense, I think. But I learned that "The date column will be implicitly converted to a character string (according to nls_date_format) before the comparison" (https://forums.oracle.com/forums/thread.jspa?threadID=2132385[^]) with Oracle. Never did I expect such a nonsense. What's your requirement behind that LIKE?
And I guess that the cited text shows the reason for the failure in one situation and the success in another: the nls_date_format differs.
|
|
|
|
|
What I am trying to do is capture any records that happened that day. Where it is a datetime field there are 24 records during that time period. I can always put in qualifers for midnight to midnight however I thought the LIKE would work. I will have to try the other way I guess...
|
|
|
|
|
General 
News 
Suggestion 
Question 
Bug 
Answer 
Joke 
Praise 
Rant 
Admin 
Submit an article or tip
