Full Code Below
Hi Again,
Yes, it's all done via VBA.
Sub I) open IE & webpage, submit date in webpage field based on cell value A1
then copy/paste all to WebDrop
Sub II) TrimRange, Column D contains 123- (- is a blank space), this removes the space.
*As the space is trimed-out, my =VlookUp formula in T10:down, goes from N/A to correct ,8,false result.
Sub III)CopyData, select only want I need as a final result and Paste in DCC as value only, no formulas.
Sub IV) to work on a custom header... don't go there....
Sub A & B) save final DCC as seperate Book name = Z1.value
and close MasterFile unsaved.
It works great as it is, but column T could be erased / modify by accident..
See full code below...
---------------------------
Sub I_GetWebData()
'
' DOF Macro
' Macro recorded 11/20/2005 by
'Open site if it requires a PassWord Model or field input validation
Dim ie As Object
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
'Go to this Web Page: DCC in this case
ie.Navigate "http://private.intranet.sorry"
'Check for good connection to web page loop!
Do
If ie.ReadyState = 4 Then
ie.Visible = False
Exit Do
Else
DoEvents
End If
Loop
'Wait for window to open!
Application.Wait (Now + TimeValue("0:00:03"))
'MsgBox "Done"
ie.Visible = True
AppActivate ie.LocationName & " - Microsoft Internet Explorer"
'Send date based on Cell A1, date value 12/12/99
SendKeys "{TAB}", True
SendKeys "{TAB}", True
'May need additional SendKeys as needed?
'Determine by the actual key-stroks needed!
SendKeys Sheets("WebDrop").[a1].Value, True
SendKeys "{TAB}", True
SendKeys "{ENTER}", True
Application.Wait (Now + TimeValue("0:00:10"))
With ie
.Visible = True
DoEvents
.ExecWB 17, 2
.ExecWB 12, 2
Sheet2.Paste Sheets("WebDrop").Range("A2")
End With
Application.Wait (Now + TimeValue("0:00:01"))
ie.Quit
Range("H2").Select
Call II_TrimRange
End Sub
Sub II_TrimRange()
'
' TrimRange Macro
' Macro recorded 11/15/2005 by
Sheets("WebDrop").Select
Application.Wait (Now + TimeValue("0:00:02"))
Dim WorkRange As Range
Set WorkRange = Range("D10", Range("D65536").End(xlUp))
For Each Cell In WorkRange
If Cell.Value = "" Then
GoTo Next1
ElseIf IsNumeric(Cell.Value) Then
Cell.Value = Cell.Value * 1
Else
Cell.Value = Trim(Cell.Value)
End If
Next1:
Next Cell
Application.Wait (Now + TimeValue("0:00:02"))
Call III_CopyData
End Sub
Sub III_CopyData()
'Copies Web results from "WebDrop" to "DCC" as values only
Sheets("WebDrop").Select
Range("A10:G65536").Copy
Sheets("DCC").Range("A2").PasteSpecial Paste:=xlPasteAll, Operation:=xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False
'Column T does not come from the Web, it contains the =Vlookup in T10 to T1500, which show as N/A# until the "TrimRange" macro runs...
Range("T10:T65536").Select
Selection.Copy
Sheets("DCC").Select
Range("J2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("H2").Select
'Call IV_EditHeader *** Forget the header code, needs work *****
End Sub
Sub B_SaveAs_BackUp()
Call I_GetWebData
Worksheets("DCC").Copy
Dim filename As String, path As String, savefile As String
'Change to "C:\....\......\ **VerifY**
path = "F:\Macros\BU\"
filename = Range("W1").Value
savefile = path & filename & ".xls"
ActiveWorkbook.SaveAs savefile
Workbooks("MasterFile.xls").Saved = True
Workbooks("MasterFile.xls").Close True
End Sub
Sub A_SaveAs_DOF()
Call I_GetWebData
Worksheets("DCC").Copy
Dim filename As String, path As String, savefile As String
'Change to "C:\....\....\ **VerifY**
path = "F:\Macros\DOF\"
filename = Range("Y1").Value
savefile = path & filename & ".xls"
ActiveWorkbook.SaveAs savefile
'saved = false > testing
Workbooks("MasterFile.xls").Saved = True
Workbooks("MasterFile.xls").Close True
End Sub
Sub IV_EditHeader()' Needs work....
Dim mySht As Variant
'Referencing a cell in a header macro
For Each mySht In Worksheets
mySht.Activate
ActiveSheet.PageSetup.RightHeader = strHdr & _
Format(Worksheets("DCC").Range("B2").Value, "dddd, mmm-dd, yyyy")
RightHeader.FontSize = 22
End Sub
