I am trying to scape data from a web table.
I login to a website, which gives me access to a web table.
That table contains a hyperlink column (Id) like the example you can see below. I want to click on id "3547" when the PO = "WO-JL31" for example.
ID \\ \ Date \\ \ \\ PO\\ \\ Amount
3547\\02/2022\WO-JL31\ $3254
I am able to read and debug.print the whole html file of the table.
How do I click on 3524?
Dim HTMLTables As MSHTML.IHTMLElementCollection
Dim HTMLTable As MSHTML.IHTMLElement
Dim HTMLDetails As MSHTML.IHTMLElementCollection
Dim HTMLDetail As MSHTML.IHTMLElement
Dim HTMLTableSection As MSHTML.IHTMLElement
Dim HTMLTableRow As MSHTML.IHTMLElement
Dim HTMLTableCell As MSHTML.IHTMLElement
Dim RowText As String
Set HTMLTable = HTMLDoc.getElementsByTagName("table")(2)
Set HTMLDetails = HTMLDoc.getElementsByTagName("td")
For Each HTMLTableSection In HTMLTable.Children
Debug.Print , HTMLTableSection.tagName
For Each HTMLTableRow In HTMLTableSection.Children
RowText = ""
For Each HTMLTableCell In HTMLTableRow.Children
RowText = RowText & vbTab & HTMLTableCell.innerText
' From here I am able to print only the row of the table
' were the PO = “WO-JL31” as you can see the code below.
' (I am not sure if this is the best way to do it as it
' takes too much time to print.)
If InStr(RowText, "KA-PL32") > 0 Then
Debug.Print , , RowText
Exit For
End If
Next HTMLTableCell
Next HTMLTableRow
Next HTMLTableSection
This is the result: 3547 WO-JL31
How do I click on the hyperlink 3547 where the PO= WO-JL31?
Related
I am a bit new to using VBA to extract data from a website to excel and i was wondering if you guys can help me on extracting data from a website to excel using vba and then make it run every hour?
I can use the code to educate myself on it
Basically, i want to go to the following website
And then just copy paste the travel times for all the roads into excel. This would include Current, Ideal and delay.
Would it be possible to do that?
You will need to add two references in your VBA library to run this code.
To add required references: (VBE > Tools > References)
Microsoft HTML Object Library & Microsft Internet Controls
After running this, you will notice that you will need to Split the string outputs to isolate the individual variables (current, ideal, delay) that you want and then you will need to systematically assign these to a table in your excel.
You should do some research on web-scraping to fully understand what is happening. If you navigate to the page > right click on a route > inspect element > you will see the below code is pulling from the tag "tr". ("tr")(3) will corrospond with the 3rd route detailed on the site.
Sub MainSub()
Dim IE As InternetExplorer
Set IE = New InternetExplorer
IE.Navigate "https://www.cp24.com/mobile/commuter-centre/traffic"
Do
DoEvents
Loop Until IE.ReadyState = ReadyState_Complete
Dim Doc As HTMLDocument
Set Doc = IE.Document
Dim FirstRoute As String
Dim SecondRoute As String
FirstRoute = Trim(Doc.getElementsByTagName("tr")(1).innerText)
SecondRoute = Trim(Doc.getElementsByTagName("tr")(2).innerText)
MsgBox FirstRoute & vbNewLine & vbNewLine & vbNewLine & SecondRoute
IE.Quit
Set IE = Nothing
End Sub
This should do what you want!
Option Explicit
Sub Web_Table_Option_One()
Dim xml As Object
Dim html As Object
Dim objTable As Object
Dim result As String
Dim lRow As Long
Dim lngTable As Long
Dim lngRow As Long
Dim lngCol As Long
Dim ActRw As Long
Set xml = CreateObject("MSXML2.XMLHTTP.6.0")
With xml
.Open "GET", "https://www.cp24.com/mobile/commuter-centre/traffic", False
.send
End With
result = xml.responseText
Set html = CreateObject("htmlfile")
html.body.innerHTML = result
Set objTable = html.getElementsByTagName("Table")
For lngTable = 0 To objTable.Length - 1
For lngRow = 0 To objTable(lngTable).Rows.Length - 1
For lngCol = 0 To objTable(lngTable).Rows(lngRow).Cells.Length - 1
ThisWorkbook.Sheets("Sheet1").Cells(ActRw + lngRow + 1, lngCol + 1) = objTable(lngTable).Rows(lngRow).Cells(lngCol).innerText
Next lngCol
Next lngRow
ActRw = ActRw + objTable(lngTable).Rows.Length + 1
Next lngTable
End Sub
Set appropriate references...
I am struggling with scraping some data from a website. I have stepped through and for some reason the Question.className does not match what I have and what I have checked on the inspector on the web page. When I say match, nothing seems to be assigned. I have just started to look at data scraping and would appreciate any tips. I haven't included all code as the below code is the where the error occurs. Thanks in advance and apologise if this has been asked before but I couldn't find anything after having a search so thought I would post.
The URL is - https://stackoverflow.com
Range("A3").Value = "Question id" 'put heading across the top of row 3
Range("B3").Value = "Votes"
Range("C3").Value = "Views"
Range("D3").Value = "Person"
Dim QuestionList As IHTMLElement
Dim Questions As IHTMLElementCollection
Dim Question As IHTMLElement
Dim RowNumber As Long
Dim QuestionId As String
Dim QuestionFields As IHTMLElementCollection
Dim QuestionField As IHTMLElement
Dim votes As String
Dim views As String
Dim QuestionFieldLinks As IHTMLElementCollection
Set QuestionList = html.getElementById("question-mini-list")
Set Questions = QuestionList.Children
RowNumber = 4
For Each Question In Questions
'if this is the tag containing the question details, process it
If Question.className = "question-summary narrow" Then
'first get and store the question id in first column
QuestionId = Replace(Question.ID, "question-summary-", "")
Cells(RowNumber, 1).Value = CLng(QuestionId)
'get a list of all of the parts of this question, and loop over them
Set QuestionFields = Question.all
For Each QuestionField In QuestionFields
'if this is the question's votes, store it (get rid of any surrounding text)
If QuestionField.className = "votes" Then
votes = Replace(QuestionField.innerText, "votes", "")
votes = Replace(votes, "vote", "")
Cells(RowNumber, 2).Value = Trim(votes)
End If
'likewise for views (getting rid of any text)
If QuestionField.className = "views" Then
views = QuestionField.innerText
views = Replace(views, "views", "")
views = Replace(views, "view", "")
Cells(RowNumber, 3).Value = Trim(views)
End If
'if this is the bit where author's name is ...
If QuestionField.className = "started" Then
'get a list of all elements within, and store the text in the second one
Set QuestionFieldLinks = QuestionField.all
Cells(RowNumber, 4).Value = QuestionFieldLinks(2).innerHTML
End If
Next QuestionField
'go on to next row of worksheet
RowNumber = RowNumber + 1
End If
Next
Try this. It should fetch you the required fields:
Sub GetInformation()
Dim Http As New XMLHTTP60, Html As New HTMLDocument
Dim post As HTMLDivElement, URL$, R&
URL = "https://stackoverflow.com/"
With Http
.Open "GET", URL, False
.send
Html.body.innerHTML = .responseText
End With
For Each post In Html.getElementsByClassName("question-summary")
R = R + 1: Cells(R, 1) = Split(post.getAttribute("id"), "-")(2)
Cells(R, 2) = Split(post.querySelector(".votes span").getAttribute("title"), " ")(0)
Cells(R, 3) = Split(post.querySelector(".views span").getAttribute("title"), " ")(0)
Next post
End Sub
Reference to add to the library:
Microsoft XML, v6.0
Microsoft HTML Object Library
I have been trying to get this code to work for workflow efficiency purposes, but I cannot seem to make it function correctly.
Steps:
1. Login to Amazon Seller
Use order numbers in column A and place them in searchbox to search
Search for element innerText of "Estimated Delivery:" and scrape information into column B adjacent the order number
Move onto the next order number and repeat process until order number column is empty.
The webpage code (what I'm trying to obtain is highlighted):
Option Explicit
Dim HTMLDoc As HTMLDocument
Dim MyBrowser As InternetExplorer
Sub MyAmazonSellereEDD()
Dim MyHTML_Element As IHTMLElement
Dim MyURL As String
Dim oSignInLink As HTMLLinkElement
Dim oInputEmail As HTMLInputElement
Dim oInputPassword As HTMLInputElement
Dim oInputSignInButton As HTMLInputButtonElement
'InputSearchOrder will be the destination for order numbers taken from the workbook
Dim InputSearchOrder As HTMLInputElement
Dim InputSearchButton As HTMLInputButtonElement
Dim IE As InternetExplorer
Dim AAOrder As Workbook
Dim AAws As Worksheet
Dim AAws2 As Worksheet
Dim R As Range
Dim x As Integer
Dim i As Long
Dim ar As Variant
Dim elems As IHTMLElementCollection
Dim TDelement As HTMLTableCell
Dim ExcludWords() As Variant, a As Range, b As Long, LR As Long
ExcludWords = Array("Estimated Delivery:")
MyURL = "https://sellercentral.amazon.com/gp/homepage.html"
Set IE = New InternetExplorer
' Open the browser and navigate.
With IE
.Silent = True
.navigate MyURL
.Visible = True
Do
DoEvents
Loop Until .readyState = READYSTATE_COMPLETE
End With
' Get the html document.
Set HTMLDoc = IE.document
With HTMLDoc
.all.Item("username").Value = "blankityblank#blank.net"
.all.Item("password").Value = "*********"
.all.Item("sign-in-button").Click
End With
Do
DoEvents
Loop Until IE.readyState = READYSTATE_COMPLETE
Application.Wait (Now + TimeValue("0:00:08"))
'Set AAOrder = Application.Workbooks.Open("Z:\Automation Anywhere\5 Automated Tracking Imports\Amazon Prime\PrimeOrdersWithNoFulfillment.csv")
'Set AAws = AAOrder.Worksheets("PrimeOrdersWithNoFulfillment")
x = 2
'Do Until Range("A" & x) = ""
If Range("B" & x).Value = "" Then
'If AAws.Range("B" & x).Value = "" Then
'x = x + 1
Do Until Range("A" & x) = ""
Set InputSearchOrder = HTMLDoc.getElementById("sc-search-field")
InputSearchOrder.Value = Range("A" & x)
Set InputSearchButton = HTMLDoc.getElementsByClassName("sc-search-button")(0)
InputSearchButton.Click
Do
DoEvents
Loop Until IE.readyState = READYSTATE_COMPLETE
Application.Wait (Now + TimeValue("0:00:05"))
Set elems = HTMLDoc.getElementsByTagName("td")
'ExcludWords = Array("Package Weight:", "Tracking ID:", "Ship Date:", "Carrier:", "Shipping Service:")
i = 2
For Each TDelement In elems
If TDelement.className = "data-display-field" And InStr(TDelement.innerText, "Estimated Delivery:") Then
Range("B" & x).Value = TDelement.innerText
i = i + 1
End If
Next
LR = Range("B" & Rows.Count).End(xlUp).Row
For i = 1 To LR
Set a = Cells(i, "B")
For b = 0 To UBound(ExcludWords)
a.Formula = Replace((a.Formula), ExcludWords(b), "")
Next b
Next i
'End If
x = x + 1
Loop
'Loop
End If
Err_Clear:
If Err <> 0 Then
Err.Clear
Resume Next
End If
MsgBox ("Process is done! :)")
End Sub
My issue is that when it scrapes the data, the words "Estimated Delivery:" and the actual estimated delivery date it is supposed to scrape are separate, but still should be included in the output data in column B. What it's doing is finding and inserting only "Estimated Delivery:" and then using the code, it trims those characters as instructed. The space is still blank after that. I'm not sure what the issue is.
The TDelement you pick up in the following part of code only includes "Estimated Delivery:" in its innerText, the part with the date is actually a separate TDelement:
For Each TDelement In elems
If TDelement.className = "data-display-field" And InStr(TDelement.innerText, "Estimated Delivery:") Then
Range("B" & x).Value = TDelement.innerText
i = i + 1
End If
Next
As there is not any unique information in the html code (e.g. id, name etc.) to use to reference the TDelement that contains the date you could use the reference you already have in conjunction with NextSibling so that you get the element after the one that contains the text "Estimated Delivery:". Perhaps try this (unable to test anything at the moment but should work):
For Each TDelement In elems
If TDelement.className = "data-display-field" And InStr(TDelement.innerText, "Estimated Delivery:") Then
Range("B" & x).value = TDelement.NextSibling.innerText
i = i + 1
End If
Next
Thanks in advance for the help. I'm running Windows 8.1, I have the latest IE / Chrome browsers, and the latest Excel. I'm trying to write an Excel Macro that pulls data from StackOverflow (https://stackoverflow.com/tags). Specifically, I'm trying to pull the date (that the macro is run), the tag names, the # of tags, and the brief description of what the tag is. I have it working for the first page of the table, but not for the rest (there are 1132 pages at the moment). Right now, it overwrites the data everytime I run the macro, and I'm not sure how to make it look for the next empty cell before running.. Lastly, I'm trying to make it run automatically once per week.
I'd much appreciate any help here. Problems are:
Pulling data from the web table beyond the first page
Making it scrape data to the next empty row rather than overwriting
Making the Macro run automatically once per week
Code (so far) is below. Thanks!
Enum READYSTATE
READYSTATE_UNINITIALIZED = 0
READYSTATE_LOADING = 1
READYSTATE_LOADED = 2
READYSTATE_INTERACTIVE = 3
READYSTATE_COMPLETE = 4
End Enum
Sub ImportStackOverflowData()
'to refer to the running copy of Internet Explorer
Dim ie As InternetExplorer
'to refer to the HTML document returned
Dim html As HTMLDocument
'open Internet Explorer in memory, and go to website
Set ie = New InternetExplorer
ie.Visible = False
ie.navigate "http://stackoverflow.com/tags"
'Wait until IE is done loading page
Do While ie.READYSTATE <> READYSTATE_COMPLETE
Application.StatusBar = "Trying to go to StackOverflow ..."
DoEvents
Loop
'show text of HTML document returned
Set html = ie.document
'close down IE and reset status bar
Set ie = Nothing
Application.StatusBar = ""
'clear old data out and put titles in
'Cells.Clear
'put heading across the top of row 3
Range("A3").Value = "Date Pulled"
Range("B3").Value = "Keyword"
Range("C3").Value = "# Of Tags"
'Range("C3").Value = "Asked This Week"
Range("D3").Value = "Description"
Dim TagList As IHTMLElement
Dim Tags As IHTMLElementCollection
Dim Tag As IHTMLElement
Dim RowNumber As Long
Dim TagFields As IHTMLElementCollection
Dim TagField As IHTMLElement
Dim Keyword As String
Dim NumberOfTags As String
'Dim AskedThisWeek As String
Dim TagDescription As String
'Dim QuestionFieldLinks As IHTMLElementCollection
Dim TodaysDate As Date
Set TagList = html.getElementById("tags-browser")
Set Tags = html.getElementsByClassName("tag-cell")
RowNumber = 4
For Each Tag In Tags
'if this is the tag containing the details, process it
If Tag.className = "tag-cell" Then
'get a list of all of the parts of this question,
'and loop over them
Set TagFields = Tag.all
For Each TagField In TagFields
'if this is the keyword, store it
If TagField.className = "post-tag" Then
'store the text value
Keyword = TagField.innerText
Cells(RowNumber, 2).Value = TagField.innerText
End If
If TagField.className = "item-multiplier-count" Then
'store the integer for number of tags
NumberOfTags = TagField.innerText
'NumberOfTags = Replace(NumberOfTags, "x", "")
Cells(RowNumber, 3).Value = Trim(NumberOfTags)
End If
If TagField.className = "excerpt" Then
Description = TagField.innerText
Cells(RowNumber, 4).Value = TagField.innerText
End If
TodaysDate = Format(Now, "MM/dd/yy")
Cells(RowNumber, 1).Value = TodaysDate
Next TagField
'go on to next row of worksheet
RowNumber = RowNumber + 1
End If
Next
Set html = Nothing
'do some final formatting
Range("A3").CurrentRegion.WrapText = False
Range("A3").CurrentRegion.EntireColumn.AutoFit
Range("A1:C1").EntireColumn.HorizontalAlignment = xlCenter
Range("A1:D1").Merge
Range("A1").Value = "StackOverflow Tag Trends"
Range("A1").Font.Bold = True
Application.StatusBar = ""
MsgBox "Done!"
End Sub
There's no need to scrape Stack Overflow when they make the underlying data available to you through things like the Data Explorer. Using this query in the Data Explorer should get you the results you need:
select t.TagName, t.Count, p.Body
from Tags t inner join Posts p
on t.ExcerptPostId = p.Id
order by t.count desc;
The permalink to that query is here and the "Download CSV" option which appears after the query runs is probably the easiest way to get the data into Excel. If you wanted to automate that part of things, the direct link to the CSV download of results is here
You can improve this to parse out exact elements but it loops all the pages and grabs all the tag info (everything next to a tag)
Option Explicit
Public Sub ImportStackOverflowData()
Dim ie As New InternetExplorer, html As HTMLDocument
Application.ScreenUpdating = False
With ie
.Visible = True
.navigate "https://stackoverflow.com/tags"
While .Busy Or .READYSTATE < 4: DoEvents: Wend
Set html = .document
Dim numPages As Long, i As Long, info As Object, item As Object, counter As Long
numPages = html.querySelector(".page-numbers.dots ~ a").innerText
For i = 1 To 2 ' numPages ''<==1 to 2 for testing; use to numPages
DoEvents
Set info = html.getElementById("tags_list")
For Each item In info.getElementsByClassName("grid-layout--cell tag-cell")
counter = counter + 1
Cells(counter, 1) = item.innerText
Next item
html.querySelector(".page-numbers.next").Click
While .Busy Or .READYSTATE < 4: DoEvents: Wend
Set html = .document
Next i
Application.ScreenUpdating = True
.Quit '<== Remember to quit application
End With
End Sub
I'm not making use of the DOM, but I find it very easy to get around just searching between known tags. If ever the expressions you are looking for are too common just tweak the code a bit so that it looks for a string after a string).
An example:
Public Sub ZipLookUp()
Dim URL As String, xmlHTTP As Object, html As Object, htmlResponse As String
Dim SStr As String, EStr As String, EndS As Integer, StartS As Integer
Dim Zip4Digit As String
URL = "https://tools.usps.com/go/ZipLookupResultsAction!input.action?resultMode=1&companyName=&address1=1642+Harmon+Street&address2=&city=Berkeley&state=CA&urbanCode=&postalCode=&zip=94703"
Set xmlHTTP = CreateObject("MSXML2.XMLHTTP")
xmlHTTP.Open "GET", URL, False
On Error GoTo NoConnect
xmlHTTP.send
On Error GoTo 0
Set html = CreateObject("htmlfile")
htmlResponse = xmlHTTP.ResponseText
If htmlResponse = Null Then
MsgBox ("Aborted Run - HTML response was null")
Application.ScreenUpdating = True
GoTo End_Prog
End If
'Searching for a string within 2 strings
SStr = "<span class=""address1 range"">" ' first string
EStr = "</span><br />" ' second string
StartS = InStr(1, htmlResponse, SStr, vbTextCompare) + Len(SStr)
EndS = InStr(StartS, htmlResponse, EStr, vbTextCompare)
Zip4Digit = Left(Mid(htmlResponse, StartS, EndS - StartS), 4)
MsgBox Zip4Digit
GoTo End_Prog
NoConnect:
If Err = -2147467259 Or Err = -2146697211 Then MsgBox "Error - No Connection": GoTo End_Prog 'MsgBox Err & ": " & Error(Err)
End_Prog:
End Sub
I am new to coding VBA. Was wondering if you all could help me? I have a CSV file which is structured as the following:
- First 22 rows cover the specfic header data(this all loads in one column in excel)
- column headers for table are in Row 23
- the data is actually located from row 24 onward.
What the code needs to do is insert this data in new table with the right column titles. Also while inserting it needs to input the file name and header data in the first few columns of the table.
So far I have imported the entire CSV into an array I believe:
See what I have so far:
Sub readCSV()
Dim fs As Object
Dim fso As New FileSystemObject
Dim tsIn As Object
Dim sFileIn, filename As String
Dim aryFile, aryHeader, aryBody As Variant
sFileIn = "C:\doc\test.csv"
Set filename = fso.GetFileName(sFileIn)
Set fs = CreateObject("Scripting.FileSystemObject")
Set tsIn = fs.OpenTextFile(sFileIn, 1)
sTmp = tsIn.ReadAll
aryFile = Split(sTmp, vbCrLf)
For i = 1 To 22
aryHeader(1, i) = aryFile(i)
Next i
For i = 23 To UBound(aryFile)
aryBody(i) = Split(aryFile(i), ",")
DoCmd.RunSQL "INSERT INTO MAINS VALUES (filename,aryHeader(1),aryBody(i))"
Next i
End Sub
is this correct? Can anyone see of i am taking the right approach
UPDATE - recoded this a bit
Use DoCmd.TransferText instead of rolling out your own code:
http://msdn.microsoft.com/en-us/library/office/ff835958%28v=office.15%29.aspx
In your Import Specification, you can set the starting row.
See Skip first three lines of CSV file (using DoCmd?) in MS Access for more information!
Edit: The import specification can be changed to rename the fields etc. See http://www.access-programmers.com/creating-an-import-specification-in-access-2003.aspx (the Import wizard exists in Access 2007 as well) and the Advanced dialog specifically.
I was a bit irked by the use of multiple arrays in your code (which is super confusing, to me, anyway, because you are looking at counters everywhere) so I thought I would post an alternative for you. If you can do it your way, more power to you, but if you run into problems, you can try this. Code below is much more verbose, but may save you time in the future if you hand it off or even have to come back to it yourself and have no idea what is going on (lol):
Sub ReadCSV()
On Error GoTo ErrorHandler
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim fso As Scripting.FileSystemObject
Dim tst As Scripting.TextStream
Dim strFileName As String
Dim intCurrentLine As Integer
Dim strCurrentLine As String
Dim intHeaderRows As Integer
Dim strHeader As String
Dim strHeaderDelimInField As String
'Consider these your 'constants', so you don't come back to this code in a month
'and wonder what the random numbers mean.
intHeaderRows = 22 'Number of header rows in CSV.
strHeaderDelimInField = "~" 'The character(s) you want to separate each
'header line, in field.
strFileName = "C:\IrregularCSV.csv"
intCurrentLine = 1 'Keep track of which line in the file we are currently on.
'Next two lines get a reference to your table; will add data via DAO and not SQL,
'to avoid messy dynamic SQL.
Set db = CurrentDb()
Set rst = db.OpenRecordset("Mains", dbOpenDynaset)
Set fso = New Scripting.FileSystemObject
Set tst = fso.OpenTextFile(strFileName, ForReading)
'Instead of storing data in arrays, let's go through the file line by line
'and do the work we need to do.
With tst
Do Until .AtEndOfStream
strCurrentLine = .ReadLine
If intCurrentLine <= intHeaderRows Then
strHeader = strHeader & strHeaderDelimInField & strCurrentLine
Else
'Add the records via DAO here.
rst.AddNew
'In DAO, rst.Fields("FieldName") are the columns in your table.
rst.Fields("FileName") = strFileName
'Remove leading delimiter with Right.
rst.Fields("HeaderInfo") = Right(strHeader, Len(strHeader) - 1)
'Note that Split always returns a zero-based array
'and is unaffected by the Option Base statement.
'The way below is less efficient than storing
'the return of Split, but also less confusing, imo.
rst.Fields("Field1") = Split(strCurrentLine, ",")(0)
rst.Fields("Field2") = Split(strCurrentLine, ",")(1)
rst.Fields("Field3") = Split(strCurrentLine, ",")(2)
rst.Update
End If
intCurrentLine = intCurrentLine + 1
Loop
End With
tst.Close
rst.Close
ExitMe:
Set tst = Nothing
Set fso = Nothing
Set rst = Nothing
Set db = Nothing
Exit Sub
ErrorHandler:
Debug.Print Err.Number & ": " & Err.Description
GoTo ExitMe
End Sub
To be honest, I think there are a lot of gotchas to the way you are going about it. Not saying it won't work, because I think it can, but this method is more robust. An unexpected single quote won't ruin your work and using a data object to do the inserts is not prone (well, less, at least) to SQL injection issues. And I've done it with no persisted arrays. Anyway, some food for thought. Good luck.
this is what i ended up:
Sub ReadCSV2()
Dim fs As Object
Dim filename As String
Dim tsIn As Object
Dim sFileIn As String
Dim aryHeader, aryBody As Variant
Dim Text As String
Dim sqlcre As String
Dim sqlsta As String
sFileIn = "C:\test\test.csv"
filename = GetFilenameFromPath(sFileIn) 'function to get the file name
Set fs = CreateObject("Scripting.FileSystemObject")
Set tsIn = fs.OpenTextFile(sFileIn, 1)
For i = 1 To 23
Tmps = tsIn.ReadLine
Next i
aryHeader = Split(Tmps, ",")
On Error Resume Next
DoCmd.RunSQL "DROP TABLE tempdata"
On Error GoTo 0
sqlcre = "CREATE TABLE tempdata ([Filename] Text,"
For k = LBound(aryHeader) To UBound(aryHeader)
sqlcre = sqlcre & "[" & aryHeader(k) & " " & k + 1 & "] Text,"
Next k
k = k - 1
sqlcre = Left(sqlcre, Len(sqlcre) - 13) & ")"
'Debug.Print k
'Debug.Print sqlcre
DoCmd.RunSQL sqlcre
DoCmd.SetWarnings False
While Not tsIn.AtEndOfStream
Tmps = tsIn.ReadLine
aryBody = Split(Tmps, ",")
sqlsta = "INSERT INTO tempdata VALUES ('" & filename & "','"
For M = LBound(aryBody) To UBound(aryBody)
sqlsta = sqlsta & Replace(aryBody(M), "'", "`") & "', '"
Next M
M = M - 1
Debug.Print M
If M < k Then
Text = ""
For i = 1 To (k - M)
Text = Text & "', '"
Next i
sqlsta = sqlsta & Text
End If
sqlsta = Left(sqlsta, Len(sqlsta) - 7) & ")"
'Debug.Print sqlsta
'Debug.Print k
DoCmd.RunSQL sqlsta
Wend
DoCmd.SetWarnings True
End Sub