Hi all hope you can help me with this, Ive just taken over from someone and from what I can see they have been calculating a statistic used for reporting in a very haphazard way here is my table:
What I need to be able to do is using the user_id check which categorys have been opened against that user_id that appear more than once within 72 and report these as a 0 and any not fitting this as 1.
My predecessor used this formula =IF($E11=$F11,1,IF($W11<5/60,1,0)) but this doesnt take into account if the category has been opened again within 72hours, just the time it has taken to close in the first instance.
Any help or ideas greatly appreciated.
HTML:
Option Explicit: Option Base 1
'======================================================================================================================
'Written by Colo and Ivan F Moala
'Need to enable JavaScript of IE
'Last modified 8th Oct. 2002 Colo
'// 15th May 2003 IFM
'======================================================================================================================
Public Declare Function ShowWindow _
Lib "user32" ( _
ByVal hwnd As Long, _
ByVal nCmdShow As Long) _
As Long
Public Declare Function SetForegroundWindow _
Lib "user32" ( _
ByVal hwnd As Long) _
As Long
Public rngSelection As Range
Public blnPt As Boolean
Public rngPtLabel As Range
Sub HtmlMaker()
On Error GoTo Errline
'===Version update change here=======================================================================================
Const sVers As String = "[HtmlMaker 2.42] "
Const sDate As String = "15th May 2003"
'===Constant Colors===================================================================================================
Const strTbColor As String = " BGCOLOR=#0C266B "
Const strMnColor As String = " BGCOLOR=#D4D0C8 "
'===Constant Msgs Message change here=================================================================================
Const strMsg1 As String = "Select the range you would like to change into HTML" & vbLf & vbLf & _
"You need to select more than 4 columns for reproducing an image" & _
" of Excel Application."
Const strMsg2 As String = "Please select cells within 30 rows * 26 columns for submit to Message Board" & _
vbLf & vbLf & "Do you continue to generate? (But don't submit to Message Bord)" & _
vbLf & vbLf & "If you would like to select range again, please press [No]" & _
vbLf & vbLf & "If you would like to quit, please press [Cancel]"
Const strMsg3 As String = "___Running: "
Const strMsg4 As String = "To see the formula in the cells just click on the cells hyperlink " & _
"or click the Name box"
Const strMsg7 As String = "View Source"
Const strMsg8 As String = "Please click this button to send the source to clipbord"
Const strMsg9 As String = "This free code was written by Colo and Ivan F Moala:"
Const strMsg10 As String = "Code mods by Ivan F Moala - "
Const strMsg11 As String = "Please wait......... HtmlMaker is generating your sheet image into HTML"
Const strMsg12 As String = "Please wait......... writing html file"
Const strMsg13 As String = "Copy Formula"
Const strMsg14 As String = "PLEASE DO NOT QUOTE THIS TABLE IMAGE ON SAME PAGE! OTHEWISE, ERROR OF JavaScript OCCUR."
Const strMsg15 As String = "Html source of above image\n\nhas been copied to your clip board\n\nJust paste it into Message Body\n\n" & _
"If you cannnot paste source from clip board,\n\nclick [View Source] button and paste manually."
Const strMsg16 As String = "Please click [Yes], when you would like to use FormulaLocal for display Formula."
Const strCaution As String = "The Maximum charactor count of MrExcel message board is 60000."
Const strCution1 As String = _
"The generated html code size over the maximum characters size of MrExcel message board." & vbLf & _
"If you want to post, please retry to select less than this time."
Const strCution2 As String = "The size of html generated is "
Const strCution3 As String = "You can write message approximately "
Const strCution4 As String = " more characters."
Const lngMaxChr As Long = 60000 'in fact 65535 but just in case less than Max size
'===Constant TiTle Bar==================================================================================================
Const strTitleBar As String = "(<U>F</U>)ile (<U>E</U>)dit (<U>V</U>)iew (<U>I</U>)nsert (<U>O</U>)ptions " & _
"(<U>T</U>)ools (<U>D</U>)ata (<U>W</U>)indow (<U>H</U>)elp " & _
"<A HREF=""#javascript:void(0)"" onClick=""show_popup();"">(<U>A</U>)bout</A>"
'===Variables============================================================================================================
Dim intX As Integer, lngCol As Long, lngRow As Long, objIe As Object
Dim lngXX As Long, lngYY As Long, strBuf As String, strBuf2 As String, strFmBar As String
Dim intCnt As Integer, strClTxt As String, strClFml As String, strDefoltFml As String
Dim strFont As String, sFilePath As String, strFnColor As String, intPrgBar As Integer
Dim blnDisSttBar As Boolean, blnFlg As Boolean, fc As Integer, blnFormulaLocal As Boolean
Dim strJsFrm1 As String, strJsFrm2 As String, strJsSlt As String, strJsTxb As String, strJsCb As String
Dim strHlFrm As String, strHltxb As String
'===Setting StatusBar======================================================================================================
blnDisSttBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
'===Select Range============================================================================================================
If RangeHasPivotTable(ActiveSheet.UsedRange) Then
blnPt = True
On Error Resume Next
With ActiveSheet.PivotTables(1)
Set rngSelection = Range(.TableRange2.Address)
.PivotSelect "", xlLabelOnly
Set rngPtLabel = Selection
End With
Err.Clear
On Error GoTo 0
On Error GoTo Errline
Else
reInput:
On Error Resume Next
Set rngSelection = Application.InputBox(strMsg1, Left(strMsg2, 46), Selection.Address, Type:=8)
If rngSelection Is Nothing Then Exit Sub
Err.Clear
On Error GoTo 0
On Error GoTo Errline
If rngSelection.Rows.Count > 30 Or rngSelection.Columns.Count > 26 Or rngSelection.Rows.Count = Rows.Count Then
Select Case MsgBox(strMsg2, vbQuestion + vbYesNoCancel)
Case vbNo: GoTo reInput
Case vbCancel: Exit Sub
End Select
End If
End If
If MsgBox(strMsg16, vbYesNo + vbQuestion) = vbYes Then blnFormulaLocal = True
If rngSelection.Columns.Count < 4 Then Set rngSelection = rngSelection.Resize(, 4)
intX = rngSelection.Columns.Count - 3
lngXX = rngSelection.Item(1).Row - 1
lngYY = rngSelection.Item(1).Column - 1
sFilePath = ThisWorkbook.Path & "\temp.htm"
'===Make Variable name for JavaScript=========================================================================================
strJsFrm1 = Muon("formCb")
strJsFrm2 = Muon("formFb")
strJsCb = Muon("btCb")
strJsSlt = Muon("sltNb")
strJsTxb = Muon("txbFb")
strHlFrm = Muon("Hl")
strHltxb = Muon("txbHl")
'===Make Strings===============================================================================================================
strBuf = "<SCRIPT LANGUAGE=""JavaScript"" SRC=""http://www.interq.or.jp/sun/puremis/colo/popup.js""></SCRIPT><CENTER><TABLE align=CENTER cellpadding=0 cellspacing=0>"
'===Title=======================================================================================================================
strBuf = strBuf & "<TR><TD COLSPAN=" & intX + 4 & strTbColor & "style=""border-left:.5pt solid #000000;border-right:.5pt solid #000000;border-top:.5pt solid #000000;"">"
' WIDTH=100%
strBuf = strBuf & "<TABLE ALIGN=CENTER BORDER=0 WIDTH=100%><TR><TD ALIGN=LEFT><FONT COLOR=WHITE>Microsoft Excel - " & ActiveWorkbook.Name & "</FONT></TD>"
strBuf = strBuf & "<TD ALIGN=RIGHT style=""font-size:9pt;color:#000000;font-family:caption;color:#ffffff;"">" & strMsg3 & Xl_Os_Version & "</FONT></TD></TR></TABLE>"
strBuf = strBuf & "</TD></TR>"
'===Menu========================================================================================================================
strBuf = strBuf & "<TR><TD" & strMnColor & "COLSPAN=" & 4 + intX & " style=""border-left:.5pt solid #000000;border-right:.5pt solid #000000;height:25px;"">"
strBuf = strBuf & "<TABLE BORDER=0 ALIGN=CENTER VALIGN=MIDDLE WIDTH=100%><TR><TD style=""font-size:10pt;color:#000000;font-family:caption;"">" & strTitleBar
strBuf = strBuf & "</TD><TD ALIGN=RIGHT VALIGN=MIDDLE><FORM NAME='" & strJsFrm1 & "'><INPUT TYPE='Button' NAME='" & strJsCb & "' value='" & strMsg13
strBuf = strBuf & "' onClick='window.clipboardData.setData(""Text"",document." & strJsFrm2 & "." & strJsSlt & ".value);'></FORM>"
strBuf = strBuf & "</TD></TR></TABLE></TD></TR>"
'===Formula Bar==================================================================================================================
strFmBar = strFmBar & "<TR><TD BGCOLOR=WHITE COLSPAN=" & intX + 4 & " style=""border-left:.5pt solid #000000;border-right:.5pt solid #000000;"">"
strFmBar = strFmBar & "<TABLE BORDER=0><TR><Form name='" & strJsFrm2 & "'>"
strFmBar = strFmBar & "<TD ALIGN=CENTER BGCOLOR=White style=""width: 60px;"">"
strFmBar = strFmBar & "<SELECT NAME='" & strJsSlt & "' onChange='document." & strJsFrm2 & "." & strJsTxb & ".value = document." & strJsFrm2 & "." & strJsSlt & ".value'>"
'===Cells=========================================================================================================================
strBuf2 = strBuf2 & "<TR>"
strBuf2 = strBuf2 & "<TD WIDTH=2% ALIGN=CENTER style=""border-top:.5pt solid #000000;border-left:.5pt solid #000000;border-right:.5pt solid #000000;background-color:#D4D0C8;""><BR></TD>"
For lngCol = 1 + lngYY To rngSelection.Columns.Count + lngYY
strBuf2 = strBuf2 & "<TD ALIGN=CENTER style=""font-size:10pt;color:black;font-family:menu;border-top:.5pt solid #000000;border-right:.5pt solid #000000;background-color:#D4D0C8;"">"
strBuf2 = strBuf2 & "<CENTER>" & A1_Address(lngCol) & "</CENTER></TD>"
Next
strBuf2 = strBuf2 & "</TR>"
For lngRow = 1 + lngXX To rngSelection.Rows.Count + lngXX
strBuf2 = strBuf2 & "<TR>"
strBuf2 = strBuf2 & "<TD WIDTH=2% ALIGN=CENTER style=""font-size:10pt;color:#000000;font-family:menu;border-top:.5pt solid #000000;border-left:.5pt solid #000000;background-color:#D4D0C8;"">"
strBuf2 = strBuf2 & "<CENTER>" & lngRow & "</CENTER></TD>"
For lngCol = 1 + lngYY To rngSelection.Columns.Count + lngYY
'===Counter========================================================================================================================
intPrgBar = intPrgBar + 1
Application.StatusBar = _
strMsg11 & intPrgBar & "(" & Int(intPrgBar / rngSelection.Count * 100) & "%) " _
& " / " & rngSelection.Count & "(100%)"
With Cells(lngRow, lngCol)
'===Select Case=====================================================================================================================
On Error Resume Next
If .MergeArea.Address <> .Offset(, -1).MergeArea.Address Then
If .MergeArea.Address <> .Offset(-1).MergeArea.Address Then
On Error GoTo 0
On Error GoTo Errline
strClTxt = .Text
If .HasArray Then
If blnFormulaLocal = True Then
strClFml = "{" & .FormulaLocal & "}"
Else
strClFml = "{" & .Formula & "}"
End If
Else
If blnFormulaLocal = True Then
strClFml = .FormulaLocal
Else
strClFml = .Formula
End If
End If
If strClFml = "" Then
strBuf2 = strBuf2 & "<TD" & GetCSSinfo(.Resize) & ">"
If CheckHyperLinks(.Resize) Then
strBuf2 = strBuf2 & "<A HREF='#javascript:void(0);' onmouseover=""document." & strHlFrm & "." & strHltxb & ".value='" & GetHyperLinks(.Resize) & "'""; onmouseout=""document." & strHlFrm & "." & strHltxb & ".value='To see it please on mouse over the cells hyperlink'"">"
strBuf2 = strBuf2 & "</A> </TD>"
Else
strBuf2 = strBuf2 & " </TD>"
End If
Else
'===For HTML========================================================================================================================
strClTxt = MySubstitute(strClTxt, Chr(10), "<BR>")
strClTxt = MySubstitute(strClTxt, " ", " ")
If Not .HasFormula Then
If .Font.Underline <> -4142 Then strClTxt = "<U>" & strClTxt & "</U>"
strBuf2 = strBuf2 & "<TD " & GetCSSinfo(.Resize) & ">"
If CheckHyperLinks(.Resize) Then
strBuf2 = strBuf2 & "<A HREF='#javascript:void(0);' onmouseover=""document." & strHlFrm & "." & strHltxb & ".value='" & GetHyperLinks(.Resize) & "'""; onmouseout=""document." & strHlFrm & "." & strHltxb & ".value='To see it please on mouse over the cells hyperlink'"""
strBuf2 = strBuf2 & strClTxt & "</A></TD>"
Else
strBuf2 = strBuf2 & strClTxt & "</TD>"
End If
Else
'===For make formulabar============================================================================================================
strClFml = MySubstitute(strClFml, Chr(&H22), """)
strClFml = MySubstitute(strClFml, Chr(&H27), "'")
strFmBar = strFmBar & "<option value=" & Chr(&H27) & strClFml & Chr(&H27) & ">" & .Address(0, 0)
If Not blnFlg Then strDefoltFml = strClFml
blnFlg = True
If strClTxt = "" Then strClTxt = " <BR>"
If .Font.Underline <> -4142 Then strClTxt = "<U>" & strClTxt & "</U>"
strBuf2 = strBuf2 & "<TD " & GetCSSinfo(.Resize) & _
"><A HREF='#javascript:void(0);' onClick='document." & strJsFrm2 _
& "." & strJsSlt & ".options[" & fc & "].selected=true; document." _
& strJsFrm2 & "." & strJsTxb & ".value = document." & strJsFrm2 & _
"." & strJsSlt & ".value;'"
If CheckHyperLinks(.Resize) Then
strBuf2 = strBuf2 & " onmouseover=""document." & strHlFrm & "." & strHltxb & ".value='" & GetHyperLinks(.Resize) & "'""; onmouseout=""document." & strHlFrm & "." & strHltxb & ".value='To see it please on mouse over the cells hyperlink'"""
End If
strBuf2 = strBuf2 & ">" & strFont & strClTxt & "</FONT></A></TD>"
fc = fc + 1
End If
End If
End If
End If
End With
Next
strBuf2 = strBuf2 & "</TR>"
Next
strBuf2 = strBuf2 & "<TR><TD COLSPAN=" & 4 + intX & " style=""border-left:.5pt solid #000000;border-bottom:.5pt solid #000000;border-right:.5pt solid #000000;border-top:.5pt solid #808080;;background-color:#D4D0C8;"">"
strBuf2 = strBuf2 & "<TABLE ALIGN=LEFT VALIGN=TOP width=100%><TR>"
If CheckHyperLinks(rngSelection) Then
strBuf2 = strBuf2 & "<TD VALIGN=TOP ALIGN=LEFT ROWSPAN=2><TABLE VALIGN=TOP><TR><TD style=""border-left:.5pt solid #000000;border-bottom:.5pt solid #000000;border-right:.5pt solid #000000;border-top:.5pt solid #808080;background-color: #FFFFFF; width:120pt;""><U><CENTER>" & ActiveSheet.Name & "</CENTER></U></TD></TR></TABLE></TD>"
strBuf2 = strBuf2 & "<TD ALIGN=CENTER style=""font-size:9pt;color:#003366;font-family:caption;"">Hyper Lynks Address is here ...</TD></TR><TR><TD ALIGN=CENTER><FORM NAME=" & strHlFrm & " ><INPUT TYPE=TEXT NAME=" & strHltxb & " SIZE=80 VALUE='To see it please on mouse over the cells hyperlink' READONLY></FORM></TD>"
Else
strBuf2 = strBuf2 & "<TD ALIGN=LEFT style=""border-left:.5pt solid #000000;border-bottom:.5pt solid #000000;border-right:.5pt solid #000000;border-top:.5pt solid #808080;background-color: #FFFFFF; width:120pt;""><U>" & ActiveSheet.Name & "</U></TD><TD> </TD>"
End If
strBuf2 = strBuf2 & "</TR></TABLE></TD>"
strBuf2 = strBuf2 & "</TR></TABLE><BR><FONT COLOR=#339966 SIZE=1>" & sVers & "</FONT><FONT COLOR=#339966 SIZE=1>" & strMsg4 & "</FONT><BR>"
strBuf2 = strBuf2 & "<FONT COLOR=RED SIZE=1>" & strMsg14 & "</FONT></CENTER>"
If Not blnFlg Then strFmBar = strFmBar & "<option value=" & Chr(&H27) & strClFml & Chr(&H27) & ">" & ActiveCell.Address(0, 0)
strFmBar = strFmBar & "</select>"
strFmBar = strFmBar & "</TD>"
strFmBar = strFmBar & "<TD WIDTH=3% ALIGN=RIGHT" & strMnColor & "><B>=</B></TD>"
If Not blnFlg Then
strFmBar = strFmBar & "<TD ALIGN=LEFT BGCOLOR=White><input type='text' name='" & strJsTxb & "' size='80' value=" & Chr(&H27) & ActiveCell.Formula & Chr(&H27) & "></TD>"
Else
strFmBar = strFmBar & "<TD ALIGN=LEFT BGCOLOR=White><input type='text' name='" & strJsTxb & "' size='80' value='" & strDefoltFml & "'></TD>"
End If
strFmBar = strFmBar & "</form>"
strFmBar = strFmBar & "</TR></TABLE>"
strFmBar = strFmBar & "</TD></TR>"
strBuf = strBuf & strFmBar & strBuf2
Application.StatusBar = strMsg12
'===Output to make Html file================================================================================================================
Open sFilePath For Output As #1
Print #1, "<HTML><HEAD>"
Print #1, "<Script Langage JavaScript>"
Print #1, "<!---"
Print #1, "function ViewSource() {"
Print #1, "var HtmlSource;"
Print #1, "HtmlSource = document.all.ForSubmit.innerHTML;"
Print #1, "HtmlSource = RetDeleted(HtmlSource);"
Print #1, "document.write('<HTML><BODY BGCOLOR=#E0F4EA><CENTER><FORM><TEXTAREA ROWS=30 COLS=90%>');"
Print #1, "document.write(HtmlSource);"
Print #1, "document.write('</TEXTAREA></FORM></CENTER></BODY></HTML>');"
Print #1, "}"
Print #1, "function CopyToClipBoard() {"
Print #1, "var HtmlSource;"
Print #1, "HtmlSource = document.all.ForSubmit.innerHTML;"
Print #1, "HtmlSource=RetDeleted(HtmlSource);"
Print #1, "window.clipboardData.setData(""Text"",HtmlSource);"
Print #1, "alert('" & strMsg15 & "');"
Print #1, "}"
Print #1, "function RetDeleted(targetstring) {"
Print #1, "if (targetstring.indexOf(unescape('%0D%0A')) > -1) rcode = unescape('%0D%0A')"
Print #1, "else if (targetstring.indexOf(unescape('%0A')) > -1) rcode = unescape('%0A')"
Print #1, "else rcode = unescape('%0D');"
Print #1, "i = 0;"
Print #1, "p = '';"
Print #1, "while (targetstring.indexOf(rcode,i) != -1) {"
Print #1, "m = targetstring.indexOf(rcode,i);"
Print #1, "p += targetstring.substring(i,m);"
Print #1, "i = m + rcode.length;"
Print #1, "}"
Print #1, "p += targetstring.substring(i,targetstring.length);"
Print #1, "return p;"
Print #1, "}"
Print #1, "</Script>"
Print #1, "</HEAD><BODY BGCOLOR=#E0F4EA>"
Print #1, "<CENTER><FONT COLOR=#339966 SIZE=5>" & sVers & "</FONT><BR><BR></CENTER><HR><BR>"
Print #1, "<SPAN id='ForSubmit'>"
Print #1, strBuf
Print #1, "</SPAN>"
Print #1, "<BR><CENTER><HR>"
Print #1, "<FORM NAME='form1'><INPUT TYPE='Button' value='" & strMsg8 & _
"' onClick='CopyToClipBoard();'>"
Print #1, "<INPUT TYPE='Button' value='" & strMsg7 & _
"' onClick='ViewSource();'></FORM>"
Print #1, "<FONT COLOR=#339966 SIZE=2> " & strMsg9 & sVers & " - " & sDate & "</FONT><BR>"
Print #1, "<FONT COLOR=#339966 SIZE=2>" & strMsg10 & sDate & "</FONT></HR>"
Print #1, "</BODY></HTML>"
Close #1
'===If Ie NOT installed Or Version < 4 then Exit=====================================================================================
If IeVersion < 4 Or IeVersion = 0 Then GoTo NoIe
Set objIe = CreateObject("internetexplorer.application")
With objIe
.Visible = True
.Navigate sFilePath
End With
Application.StatusBar = ""
Application.DisplayStatusBar = blnDisSttBar
Maximise_Ie_Wnd objIe.hwnd
AppActivate Application.Caption
If Len(strBuf) > lngMaxChr Then
MsgBox strCution1, , Len(strBuf) & "/" & lngMaxChr & "[MAX]"
Else
MsgBox strCution2 & Len(strBuf) & vbLf & strCution3 & lngMaxChr - Len(strBuf) & strCution4
End If
Maximise_Ie_Wnd objIe.hwnd
Set rngSelection = Nothing: Set objIe = Nothing
Exit Sub
Errline:
MsgBox "Error:" & Err.Number, vbCritical, "Please notify the Error No to Colo or Ivan F Moala"
Application.StatusBar = ""
Resume Next
Exit Sub
NoIe:
'===Ie msg
MsgBox "Internet Explorer is not installed!"
End Sub
Sub Maximise_Ie_Wnd(hnd As Long)
ShowWindow hnd, 3
SetForegroundWindow hnd
End SubWhat I need to be able to do is using the user_id check which categorys have been opened against that user_id that appear more than once within 72 and report these as a 0 and any not fitting this as 1.
My predecessor used this formula =IF($E11=$F11,1,IF($W11<5/60,1,0)) but this doesnt take into account if the category has been opened again within 72hours, just the time it has taken to close in the first instance.
Any help or ideas greatly appreciated.
