Error on Range("A1").SpecialCells(xlLastCell)) - ms-access

I am getting a "Method 'Range' of object '_Global' failed" error about 50% of the time I try to run the below code. Debug takes me to this line:
Set rng = xlWS.Range(Range("A1"), xlWS.Range("A1").SpecialCells(xlLastCell))
Can anyone help with this problem?? Thanks.
Private Sub Command48_Click()
'On Error Resume Next
Dim Filename As String
Dim month1 As String
Dim year1 As Integer
Dim startTime As Date
startTime = Now
Dim strDirectoryPath As String
Filename = strDirectoryPath & "\" & "QI_GAP_REPORT_2_ " & Format$(Now(), "mm-dd-yyyy") & ".xls"
DoCmd.OpenQuery "QI_GAP_REPORT_FOR_EXCEL"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "QI_GAP_REPORT_FOR_EXCEL", Filename, False, "Summary"
DoCmd.Close acQuery, "QI_GAP_REPORT_FOR_EXCEL"
'///****Format excel workbook****////
' Late binding to avoid reference:
Dim xlApp As Object 'Excel.Application
Dim xlWB As Object 'Workbook
Dim xlWS As Object 'Worksheet
Dim GetBook As String
' Create the instance of Excel that we will use to open the temp book
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Open(Filename)
Set xlWS = xlWB.Worksheets("Summary")
' Format our temp sheet
' ************************************************** *************************
xlApp.Range("A1").Select
Const xlLandscape As Long = 2
Const xlCenter As Long = -4108
Const xlBottom As Long = -4107
Const xlContext As Integer = -5002
Const xlDown As Integer = -4121
Const xlContinuous As Integer = 1
Const xlThin As Integer = 2
Const xlLastCell As Long = 11
Const xlYes As Long = 1
With xlWS
With .UsedRange
.borders.LineStyle = xlContinuous
.borders.ColorIndex = 0
.borders.TintAndShade = 0
.borders.Weight = xlThin
End With
'format header 90 degree
With .Range("i1:y1")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
.UsedRange.Rows.RowHeight = 15
.UsedRange.Columns.AutoFit
Dim tbl As ListObject
Dim rng As Range
Set rng = xlWS.Range(Range("A1"), xlWS.Range("A1").SpecialCells(xlLastCell))
Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, rng, , xlYes)
tbl.TableStyle = "TableStyleMedium2"
tbl.ShowTotals = True

Related

web scraping from google page no longer returns anything

The below Excel vba code use to work and return the market cap, 52 week low and current price into my spreadsheet. It no longer does though and cannot work out why. Class names haven't changed but the getElementsByClassName doesn't seem to return anything anymore I think.
Sub get_title_header()
Dim wb As Object
Dim doc As Object
Dim sURL As String
Dim i As Integer
Dim allElements As IHTMLElementCollection
Application.DisplayAlerts = False
Set wb = CreateObject("internetExplorer.Application")
sURL = "https://www.google.com/search?q=aapl+stock+quote"
wb.navigate sURL
wb.Visible = False
While wb.Busy
Application.Wait Now + #12:00:01 AM#
DoEvents
Wend
Set doc = wb.document.body
On Error GoTo err_clear
Set allElements = doc.getElementsByClassName("iyjjgb")
x = allElements(3).innerText
Sheet6.Cells(i + 1, 2).Value = x
x = allElements(8).innerText
Sheet6.Cells(i + 1, 3).Value = x
x = ""
x = allElements(0).innerText
Sheet6.Cells(i + 1, 4).Value = x
x = ""
err_clear:
If Err <> 0 Then
Err.Clear
Resume Next
End If
wb.Quit
End Sub

Modifying the program for parsing

There is a program that parse a certain table from the site . Works great . I want to parse another table from the site . By the tag number “table” they are the same . I am trying to use the same program , but it gives an error : Run-time error 91 in the line :
If oRow.Cells(y).Children.Length > 0 Then
New table : http://allscores.ru/soccer/fstats.php?champ=2604&team=439&team2=420&tour=110
Old table : http://allscores.ru/soccer/new_ftour.php?champ=2604&f_team=439
New table : in the attached picture
Function extractTable(Ssilka As String, book1 As Workbook, iLoop As Long)
Dim oDom As Object, oTable As Object, oRow As Object
Dim iRows As Integer, iCols As Integer
Dim x As Integer, y As Integer
Dim data()
Dim vata()
Dim tata()
Dim oHttp As Object
Dim oRegEx As Object
Dim sResponse As String
Dim oRange As Range
Dim odRange As Range
' get page
Set oHttp = CreateObject("MSXML2.XMLHTTP")
oHttp.Open "GET", Ssilka, False
oHttp.Send
' cleanup response
sResponse = StrConv(oHttp.responseBody, vbUnicode)
Set oHttp = Nothing
sResponse = Mid$(sResponse, InStr(1, sResponse, "<!DOCTYPE "))
Set oRegEx = CreateObject("vbscript.regexp")
With oRegEx
.MultiLine = True
.Global = True
.IgnoreCase = False
.Pattern = "<(script|SCRIPT)[\w\W]+?</\1>"
sResponse = .Replace(sResponse, "")
End With
Set oRegEx = Nothing
' create Document from response
Set oDom = CreateObject("htmlFile")
oDom.Write sResponse
DoEvents
' table with results, indexes starts with zero
Set oTable = oDom.getelementsbytagname("table")(3)
DoEvents
iRows = oTable.Rows.Length
iCols = oTable.Rows(1).Cells.Length
' first row and first column contain no intresting data
ReDim data(1 To iRows - 1, 1 To iCols - 1)
ReDim vata(1 To iRows - 1, 1 To iCols - 1)
ReDim tata(1 To iRows - 1, 1 To iCols - 1)
' fill in data array
For x = 1 To iRows - 1
Set oRow = oTable.Rows(x)
For y = 1 To iCols - 1
If oRow.Cells(y).Children.Length > 0 Then
data(x, y) = oRow.Cells(y).getelementsbytagname("a")(0).getattribute("href")
data(x, y) = Replace(data(x, y), "about:", "http://allscores.ru/soccer/")
vata(x, y) = oRow.Cells(y).innerText
End If
Next y
Next x
Set oRow = Nothing
Set oTable = Nothing
Set oDom = Nothing
Set oRange = book1.ActiveSheet.Cells(110, 26 + (iLoop * 21)).Resize(iRows - 1, iCols - 1)
oRange.NumberFormat = "#"
oRange.Value = data
Set odRange = book1.ActiveSheet.Cells(34, 26 + (iLoop * 21)).Resize(iRows - 1, iCols - 1)
odRange.NumberFormat = "#"
odRange.Value = vata
Set oRange = Nothing
Set odRange = Nothing
End Function
This is not particularly robust but does grab the values from the table. iLoop is not used.
Option Explicit
Public Sub test()
extractTable "http://allscores.ru/soccer/fstats.php?champ=2604&team=439&team2=420&tour=110", ThisWorkbook, 1
End Sub
Public Sub extractTable(Ssilka As String, book1 As Workbook)
Dim oDom As Object, oTable As Object
Dim oHttp As Object
Dim oRegEx As Object
Dim sResponse As String
Set oHttp = CreateObject("MSXML2.XMLHTTP")
oHttp.Open "GET", Ssilka, False
oHttp.send
sResponse = StrConv(oHttp.responseBody, vbUnicode)
Set oHttp = Nothing
sResponse = Mid$(sResponse, InStr(1, sResponse, "<!DOCTYPE "))
Set oRegEx = CreateObject("vbscript.regexp")
With oRegEx
.MultiLine = True
.Global = True
.IgnoreCase = False
.Pattern = "<(script|SCRIPT)[\w\W]+?</\1>"
sResponse = .Replace(sResponse, "")
End With
Set oRegEx = Nothing
Set oDom = CreateObject("htmlFile")
oDom.Write sResponse
Set oTable = oDom.getElementsByTagName("table")(3)
Dim b As Object, a As Object
Set b = oTable.getElementsByTagName("TR") 'DispHTMLElementCollection
Dim i As Long, y As Long
With ActiveSheet
For i = 3 To 17 '17-3 gives the 15 rows of interest. Start at 3 to avoid header and empty row.
Set a = b(i).ChildNodes
For y = 1 To a.Length - 1
.Cells(i - 2, y) = a(y).innerText
Next y
Next i
End With
End Sub

How can i add parameter code to export a query from access 2013 to excel 2013

'Below is the current code that I have and it will export to the excel workbook and worksheet correctly. The only problem is that I need to limit the data that gets exported by a month end date range (example: 1/31/2017 to 4/30/2017) and also by a plant number (example: "4101") thanks for any help it is greatly appreciated.
Public Function InventoryXport_4100()
Dim appXL As Object
Dim wb As Object
Dim wks As Object
Dim xlf As String
Dim rs As DAO.Recordset
Dim fld As Field
Dim intColCount As Integer
xlf = "Z:\COST ACCOUNTING INFO\Inventory Reports\MyFile.xlsx"
Set rs = CurrentDb.OpenRecordset("(QS)_Inventory")
Set appXL = CreateObject("Excel.Application")
Set wb = appXL.Workbooks.Open(xlf)
Set wks = wb.Sheets("Inventory Xport") 'Sheet name
If rs.EOF = True Then
MsgBox "No data", vbOKOnly
Exit Function
End If
With appXL
.Application.worksheets("Inventory Xport").SELECT
.Application.columns("A:AQ").SELECT
.Application.columns.Clear
End With
intColCount = 1
For Each fld In rs.Fields
wks.Cells(1, intColCount).Value = fld.Name
intColCount = intColCount + 1
Next fld
appXL.displayalerts = False
wks.Range("A2").CopyFromRecordset rs
appXL.Visible = True
With appXL
.Application.worksheets("Inventory Xport").SELECT
.Application.columns("A:AQ").SELECT
.Application.columns.AutoFit
.Application.Range("A2").SELECT
.Application.ActiveWindow.FreezePanes = True
End With
wb.Save
wb.Close
appXL.Quit
Set wb = Nothing
rs.Close
Set rs = Nothing
End Function
You can use:
Dim Date1 As Date
Dim Date2 As Date
Dim PlantNr As String
Dim Sql As String
Date1 = #1/31/2017#
Date2 = #4/30/2017#
PlantNr = "4101"
Sql = "Select * From [(QS)_Inventory] Where YourDateField Between #" & Format(Date1, "yyyy\/mm\/dd") & "# And #" & Format(Date2, "yyyy\/mm\/dd") & "# And [Plant Number] = '" & PlantNr & "'"
Set rs = CurrentDb.OpenRecordset(Sql)

Using Excel VBA to screen-scrape internet - cannot reference second page

my question is relatively simple and maddeningly evasive. It's not unlike many questions I've found on the internet and at StackOverflow yet no suggestions have helped my little conundrum....
Using Excel2010 I wasnt to enter data into a single field, submit it (Part1) and capture a few lines of data (part2) , paste into excel in a list/table format (part30 - and do it 999,999 times.....Part 1 and 3 are working - Part2 refuses to acknowledge the new internet window and all gettagnames and SelectTable workarounds just use the original URL - the attached was a desperate attempt using Sendkeys - which worse perfectly! - for the first loop - then absolutely nothing!
anyway, the code should be fairly simple - appologies for some mess in the coding order - it's down to me starting to cut out bits with a scalple but after hours of messing about resorted to hatchets...
Dim HTMLdoc As HTMLDocument
Dim ie As InternetExplorer
Sub EPF_FSA()
'Application.DisplayAlerts = False
Application.EnableEvents = False
Dim iHTML_Element As IHTMLElement
Dim sURL As String
Dim miss1 As Integer
Dim FrmNo As Long
Dim FrmName As String
Dim Address1 As String
Dim Address2 As String
Dim Address3 As String
Dim Address4 As String
Dim Address5 As String
Dim Address6 As String
Dim Address7 As String
Dim Address8 As String
Dim AnyLuck As String
Dim RowNum As Integer
Dim ColNum As Integer
RowNum = 1
ColNum = 1
FrmNo = 100111
While FrmNo <= 100112
'Do While FrmNo <= 100112
On Error GoTo Err_Clear
sURL = "http://www.fsa.gov.uk/register/epfSearchForm.do"
Set ie = CreateObject("internetexplorer.application")
'Set Ex = CreateObject("MicrosoftExcel.application")
ie.navigate sURL
ie.Visible = True
Do
' Wait till the Browser is loaded
Loop Until ie.readyState = READYSTATE_COMPLETE
Set HTMLdoc = ie.document
HTMLdoc.all.epfref.Value = FrmNo
For Each iHTML_Element In HTMLdoc.getElementsByTagName("input")
If iHTML_Element.Type = "submit" Then miss1 = miss1 + 1
If miss1 = 2 Then iHTML_Element.Click: Exit For
Next
Err_Clear:
If Err <> 0 Then Err.Clear
Resume Next
'PART 2 ********************************************************************
Do
' Wait till the Browser is loaded
Loop Until ie.readyState = READYSTATE_COMPLETE
Call SendKeys("^a")
DoEvents
Call SendKeys("^c")
DoEvents
ActiveSheet.PasteSpecial Format:="Text", link:=False, DisplayAsIcon:=False
range("A2").Select
'Copy and select relevant text to sheet 2
Worksheets("Sheet1").Activate
FrmName = Cells(39, "A").Value
Address1 = Cells(59, "A").Value
Address2 = Cells(60, "A").Value
Address3 = Cells(61, "A").Value
Address4 = Cells(62, "A").Value
Address5 = Cells(63, "A").Value
Address6 = Cells(64, "A").Value
Address7 = Cells(65, "A").Value
Address8 = Cells(66, "A").Value
AnyLuck = Cells(47, "A").Value
Worksheets("Sheet2").Activate
Cells(RowNum, "A").Value = FrmNo
Cells(RowNum, "B").Value = FrmName
Cells(RowNum, "C").Value = Address1
Cells(RowNum, "D").Value = Address2
Cells(RowNum, "E").Value = Address3
Cells(RowNum, "F").Value = Address4
Cells(RowNum, "G").Value = Address5
Cells(RowNum, "H").Value = Address6
Cells(RowNum, "I").Value = Address7
Cells(RowNum, "J").Value = Address8
Cells(RowNum, "K").Value = AnyLuck
RowNum = RowNum + 1
'ActiveCell.Offset(1, 0).Select
Worksheets("Sheet1").Activate
Cells.Select
Selection.Delete Shift:=xlUp
range("A2").Select
'MsgBox (FrmNo & Chr(10) & FrmName)
'Part 3
FrmNo = FrmNo + 1
ie.Quit
ie.Quit
Wend
'Loop
Application.EnableEvents = True
End Sub
Looks like you can go directly to the results page. Try:
sUrl = "http://www.fsa.gov.uk/register/epfRefSearch.do?epfRef="
sUrl = sUrl & frmNo
and then just navigate to that page. The actual details are then in a div with an ID of "box"

how to insert new row like Excel functions in MS ACCESS

I need to find a way to make grid in MS Access & insert new lines to it by code VBA only
exactly how excel behave.
Have you looked at continuous forms and datasheets?
It is very rarely a good idea to replicate spreadsheet behaviour in a database
Code InsertRows : insert row in between tow row
first Create A temporarilytable And then deal with this table like the main table
and the code is Work with me
and here the code :
Sub InsertRows()
On Error GoTo ErrorNu
Dim SQLP As String
Dim Con As New ADODB.Connection
Dim Conx As New ADODB.Connection
Dim Rst As New ADODB.Recordset
Dim Rs As New ADODB.Recordset
Dim Rsx As New ADODB.Recordset
Dim Rn As New ADODB.Recordset
Dim Rd As New ADODB.Recordset
Dim Num As Long
Dim intRows
Dim arrEmployees As Variant
Dim x As Integer, Y As Integer
Set Con = CurrentProject.Connection
Con.BeginTrans
sqlo = " select max(AutoRec)as maxa from Note_Custom "
Set Rn = Con.Execute(sqlo)
SQLP = " SELECT AutoRec, TextCOspoId, OuerM,Note"
SQLP = SQLP & " , TextBillId,NuCOspoId,dateTybe FROM Note_Custom ORDER BY AutoRec"
Rs.Open SQLP, Con, adUseClient, adOpenStatic, adCmdText
sqlo = " UPDATE Note_Custom SET TextBillId = ''"
sqlo = sqlo & " WHERE AutoRec > " & 0
Con.Execute (sqlo)
intRows = Val(Rn!maxa)
Num = 1
arrEmployees = Rs.GetRows(intRows)
Y = 0
For x = 0 To intRows - 1
If x = Val(SelTop - 1) Then
Y = 1
Rs.AddNew
Rs![AutoRec] = arrEmployees(0, x)
Rs![TextBillId] = 1
Rs.Update
End If
Rs.AddNew
Rs![AutoRec] = arrEmployees(0, x) + Y
Rs![TextCOspoId] = arrEmployees(1, x)
Rs![OuerM] = arrEmployees(2, x)
Rs![Note] = arrEmployees(3, x)
Rs![NuCOspoId] = arrEmployees(5, x)
Rs![dateTybe] = arrEmployees(6, x)
Rs![TextBillId] = 1
Rs.Update
Next x
sqlo = "DELETE * FROM Note_Custom where TextBillId = """""
Con.Execute (sqlo)
Con.CommitTrans
SelFiled = Me.SelTop
Me.Requery
sqlo = "SELECT Last(AutoRec) AS LastAuto,First(AutoRec) AS FirstAuto,Count(AutoRec) AS CountAuto FROM Note_Custom"
Set Rd = Con.Execute(sqlo)
If Me.SelTop <> AutoRec Or Rd!LastAuto <> Rd!CountAuto Then
Refix
End If
DoCmd.GoToRecord , , acGoTo, SelFiled
'Me.SelTop = SelFiled
If RecType = False Then
Forms![Ncustom]!Edite.Enabled = True
Forms![Ncustom]!Viewer1.Enabled = False
Forms![Ncustom]!DELETE.Enabled = False
End If
arrEmployees = Empty
Rs.Close
Con.Close
Set Rs = Nothing
Set Con = Nothing
Exit Sub
ErrorNu:
SelFiled = Me.SelTop
Me.Requery
Me.SelTop = SelFiled
End Sub