I'm not able to find examples on how to export multiple data sets/tables to a single Excel worksheet utilizing the EPPlus library. When I run the codes, it returns one set that happens to be the last set. What am I doing wrong with the following codes? Thanks!
Dim dSets as DataSets
Dim dGrid as DataGrid
Dim dTable as DataTable
Dim sheet as String
sheet = "DumpSets"
Dim attachment as String
attachment = "attachment; filename=" + sheet + ".xlsx"
Dim xlPack as ExcelPackage = New ExcelPackage()
Dim ws as ExcelWorksheet = xlPack.Workbook.Worksheets.Add(sheet)
Response.Clear()
Response.AddHeader("content-disposition", attachment)
Response.Charset = ""
For each dTable in dSets.Tables
dGrid = New DataGrid
Me.EnableViewState = False
dGrid.DataSource = dTable
ws.Cells(1, 1).LoadFromDataTable(dGrid.DataSource, True)
dGrid.DataBind()
Next
Response.BinaryWrite(xlPack.GetAsByteArray())
Response.End()
As #Blackwood already mentioned, you always add the data in the same place.
So it should be something like this:
Dim cnt As Integer = 1
For each dTable in dSets.Tables
dGrid = New DataGrid
Me.EnableViewState = False
dGrid.DataSource = dTable
ws.Cells(1, cnt).LoadFromDataTable(dGrid.DataSource, True)
dGrid.DataBind()
cnt = (cnt + 1)
Next
You could also add every dataset to it's own sheet.
Dim cnt As Integer = 1
For Each dt As DataTable In dSets.Tables
Dim ws As ExcelWorksheet = xlPack.Workbook.Worksheets.Add(("Sheet " + cnt))
ws.Cells(1, 1).LoadFromDataTable(dGrid.DataSource, True)
cnt = (cnt + 1)
Next
Related
I created an app that does the following:
Opens an excel spreadsheet and show a hidden sheet
Copy the data in this sheet to a temporary spreadsheet
Run some error checks on the data that's been pasted
Create a unique code in the first column based on customer no. date & time
Save the spreadsheet as a new file
Clear up to be ready for the next spreadsheet
The problem I am having is at step 6 of clearing up and releasing any excel objects in memory that can hold up moving to the next spreadsheet and so on.
The current issue I have is that an Excel object remains open and locks the tempfile.xlsx that is created which will then randomly generates the error "The file 'C:\Temp\CustOrders\Input\TempFile.xlsx' already exists." I say randomly because I can run 10 or more files through it without an issue. I could run them all again and it will produce the error after the 1st, 2nd, 3rd or later file. I cannot blame any one file for causing this.
How do I effectively close out all Excel objects ready for the next file to be processed? I have so far tried different ways to do this including trying to kill the process but this seems like a dirty sledgehammer approach.
Here's the code:
Imports Microsoft.Office.Interop.Excel
Imports Microsoft.Office.Interop
Imports System.Runtime.InteropServices
Imports System.IO
Public Class Form1
Dim xlApp As Excel.Application
Dim xlNewApp As Excel.Application
Dim xlWorkBook As Excel.Workbook
Dim xlWorkSheet As Excel.Worksheet
Dim range As Excel.Range
Dim rCnt As Integer
Dim cCnt As Integer
Dim Obj As Object
Dim TempFile() As String
Dim TempFiledir As String
Dim filename As String
Dim xlNewWorkBook As Excel.Workbook
Dim xlNewWorkSheet As Excel.Worksheet
Dim misValue As Object = System.Reflection.Missing.Value
Dim Cust As Object
Dim pfile As String
Dim NoProcessed As Integer = 0
Dim NoFailed As Integer = 0
Dim filecount As Integer = 0
Dim fileremaining As Integer = 0
Dim custFailed As Integer = 0
Dim files() As String = Directory.GetFiles("C:\Temp\CustOrders\Uploaded")
Dim di As New DirectoryInfo("C:\Temp\CustOrders\Uploaded")
Private Sub releaseObject(ByVal obj As Object)
Try
Marshal.ReleaseComObject(obj)
obj = Nothing
Catch ex As Exception
obj = Nothing
Finally
GC.Collect()
End Try
End Sub
Private Sub Form1_Load(sender As System.Object, e As System.EventArgs) Handles MyBase.Load
lblProcessingFile.Visible = False
CountFiles()
lblFileCount.Text = "Files to be processed: " & filecount
End Sub
Function CountFiles()
Dim files() As String = Directory.GetFiles("C:\Temp\CustOrders\Uploaded")
Dim di As New DirectoryInfo("C:\Temp\CustOrders\Uploaded")
If files.Count > 0 Then
filecount = di.GetFiles("*.xlsx").Count()
Else
filecount = 0
lblFileCount.Text = "Files to be processed: " & filecount
End If
End Function
Private Sub Button2_Click(sender As System.Object, e As System.EventArgs) Handles BTN_gencsv.Click
TempFiledir = ("C:\Temp\CustOrders\Input\TempFile.xlsx")
If My.Computer.FileSystem.FileExists(TempFiledir) Then
My.Computer.FileSystem.DeleteFile(TempFiledir)
End If
GetFiles()
End Sub
Sub GetFiles()
'1. Look in the UPLOADED folder for new files
Dim files() As String = Directory.GetFiles("C:\Temp\CustOrders\Uploaded")
Dim di As New DirectoryInfo("C:\Temp\CustOrders\Uploaded")
If files.Count > 0 Then
Dim arrayfi As FileInfo() = di.GetFiles("*.xlsx")
Dim fi As FileInfo
For Each fi In arrayfi
filename = fi.Name
Start(filename)
Next
Else
MsgBox("No files available in directory")
End If
End Sub
Sub Start(filename)
With BTN_gencsv
.BackColor = Color.Red
.ForeColor = Color.White
.Text = "Please wait..."
End With
'2. Get the file that has been uploaded by the customer, copy and rename as TempFile
lblProcessingFile.Visible = True
lblProcessingFile.Text = "Processing file: " & filename
IO.File.Copy("C:\Temp\CustOrders\Uploaded\" & filename, _
"C:\Temp\CustOrders\Input\TempFile.xlsx")
xlApp = New Excel.Application
xlNewApp = New Excel.Application
xlWorkBook = xlApp.Workbooks.Open("C:\Temp\CustOrders\Input\TempFile.xlsx")
xlWorkSheet = xlWorkBook.Worksheets(1)
xlWorkSheet = xlWorkBook.Worksheets("CSV")
xlWorkSheet.Visible = XlSheetVisibility.xlSheetVisible
xlWorkSheet.Unprotect("opencsv")
'3. Copy rows from the CSV worksheet including headers
xlWorkSheet.Range("A1:H100").Copy()
'4. Create new Excel workbook and worksheet so it can have have all rows pasted in
' Then perform all prep work
xlNewWorkBook = xlNewApp.Workbooks.Add(misValue)
xlNewWorkSheet = xlNewWorkBook.Worksheets(1)
xlNewWorkSheet.Select()
' Paste the rows into the new worksheet
On Error Resume Next
xlNewWorkSheet.PasteSpecial(Excel.XlPasteType.xlPasteValues)
xlApp.CutCopyMode = False
' Get current date/time
Dim dt As DateTime = DateTime.Now
Dim dt2 As String = dt
dt2 = dt2.Replace("/", "").Replace(" ", "_").Replace(":", "")
' Select customer number from worksheet
Dim xRng As Excel.Range = CType(xlNewWorkSheet.Cells(2, 5), Excel.Range)
Cust = xRng.Value().ToString()
' If the customer is not found in the spreadsheet lookup it generates "-2146826246" as a value
' This saves the cell as "Not found" to make it look friendly
If Cust.Equals("-2146826246") Then
custFailed += 1
Cust = "Cust_Not_Found_" & custFailed
failedfiles()
Else
CustNo()
End If
releaseObject(xRng)
' This now passes to two error checking subs
End Sub
Sub completeform()
'5. Generate a unique value for Netsuite based on the customer number and current date time
Dim Row As Range
Dim Index As Long
Dim Count As Long
For Index = xlNewWorkSheet.UsedRange.Rows.Count To 1 Step -1
Row = xlNewWorkSheet.UsedRange.Rows(Index)
Count = 0
On Error Resume Next
Count = Row.SpecialCells(XlCellType.xlCellTypeBlanks).Count
If Count = Row.Cells.Count Then Row.Delete(Excel.XlDirection.xlUp)
Next
Dim dt As DateTime = DateTime.Now
Dim dt2 As String = dt
dt2 = dt2.Replace("/", "").Replace(" ", "_").Replace(":", "")
pfile = (Cust + "_" + dt2)
Dim rw As Integer = 1
Do Until xlNewWorkSheet.Cells(rw, 1).Value Is Nothing
rw += 1
Loop
Dim last As String = rw - 1
With xlNewWorkSheet.Range("A1:A100")
.Range(.Cells(2, 1), .Cells(last, 1)).Value = (Cust + "_" + dt2)
End With
'6. Save the workbook with a unique name based on customer number and date/time
xlWorkBook.Saved = True
xlNewWorkBook.SaveAs("C:\Temp\CustOrders\Output\Test_" + pfile + ".csv", Excel.XlFileFormat.xlCSV, misValue, misValue, misValue, misValue, _
Excel.XlSaveAsAccessMode.xlExclusive, misValue, misValue, misValue, misValue, misValue)
'7. Close and release all Excel worksheets and workbooks so they dont remain in memory
xlNewWorkBook.Close(True, misValue, misValue)
xlWorkBook.Saved = True
xlNewWorkBook.Saved = True
releaseObject(xlNewWorkSheet)
releaseObject(xlNewWorkBook)
releaseObject(xlNewApp)
xlWorkBook.Close(False)
xlApp.Quit()
releaseObject(range)
releaseObject(xlWorkSheet)
releaseObject(xlWorkBook)
releaseObject(xlApp)
xlNewApp.Quit()
System.Threading.Thread.Sleep(2000)
'8. Move the processed workbook to the Processed folder ready for a new workbook
IO.File.Move("C:\Temp\CustOrders\Input\TempFile.xlsx", _
"C:\Temp\CustOrders\Processed\Processedfile_" + pfile + ".xlsx")
'9. Move the spreadsheet from Uploaded to OldUploaded ready for a new file
IO.File.Move("C:\Temp\CustOrders\Uploaded\" + filename, _
"C:\Temp\CustOrders\OldUploaded\Uploaded_" + filename)
NoProcessed += 1
lblProcessedCount.Text = "No. Processed..." & NoProcessed
CountFiles()
lblFileCount.Text = "Files to be processed: " & filecount
With BTN_gencsv
.BackColor = SystemColors.Control
.ForeColor = SystemColors.ControlText
.Text = "Generate CSV"
End With
lblProcessingFile.Visible = False
End Sub
Sub CustNo()
Dim c As Range
With xlNewWorkSheet.Range("A1:A100")
c = .Find("#N/A", LookIn:=XlFindLookIn.xlValues)
If Not c Is Nothing Then
custFailed += 1
Cust = "Cust_Not_Found_" & custFailed
MsgBox(Cust)
failedfiles()
Else
quantityBlanks()
End If
End With
End Sub
Sub quantityBlanks()
Dim rw As Integer = 1
Do Until xlNewWorkSheet.Cells(rw, 1).Value Is Nothing
rw += 1
Loop
Dim last As String = rw - 1
Dim rng As Excel.Range
Dim TotalBlanks As Long
TotalBlanks = 0
rng = xlNewWorkSheet.Range(xlNewWorkSheet.Cells(2, 8), xlNewWorkSheet.Cells(last, 8))
On Error Resume Next
TotalBlanks = rng.SpecialCells(XlCellType.xlCellTypeBlanks).Count
If TotalBlanks > 0 Then
Cust = "Quantity_error_"
failedfiles()
Else
referrors()
End If
rng = Nothing
End Sub
Sub referrors()
Dim c As Range
With xlNewWorkSheet.Range("A1:A100")
c = .Find("#REF!", LookIn:=XlFindLookIn.xlValues)
If Not c Is Nothing Then
Cust = "~REF!_errors_"
failedfiles()
Else
completeform()
End If
End With
End Sub
Sub failedfiles()
Dim dt As DateTime = DateTime.Now
Dim dt2 As String = dt
dt2 = dt2.Replace("/", "").Replace(" ", "_").Replace(":", "")
pfile = (Cust + "_" + dt2)
xlWorkBook.Close(False)
xlNewWorkBook.Close(False)
xlNewApp.Quit()
xlApp.Quit()
releaseObject(xlApp)
releaseObject(xlWorkBook)
releaseObject(xlWorkSheet)
releaseObject(xlNewApp)
releaseObject(xlNewWorkBook)
releaseObject(xlNewWorkSheet)
'IO.File.Delete("C:\Temp\CustOrders\Input\Newfile.xlsx")
IO.File.Move("C:\Temp\CustOrders\Input\TempFile.xlsx", _
"C:\Temp\CustOrders\Processed\ProcessedFailedfile_" + pfile + ".xlsx")
IO.File.Move("C:\Temp\CustOrders\Uploaded\" + filename, _
"C:\Temp\CustOrders\Failed\FailedFile_" + pfile + ".xlsx")
With BTN_gencsv
.BackColor = SystemColors.Control
.ForeColor = SystemColors.ControlText
.Text = "Generate CSV"
End With
NoFailed += 1
lblFailed.ForeColor = Color.Red
lblFailed.Text = "No. Failed..." & NoFailed
CountFiles()
lblFileCount.Text = "Files to be processed: " & filecount
lblProcessingFile.Visible = False
End Sub
Private Sub PictureBox1_Click(sender As System.Object, e As System.EventArgs) Handles PictureBox1.Click
CountFiles()
lblFileCount.Text = "Files to be processed: " & filecount
End Sub
End Class
To keep it simple I have several hundred word documents for clients which list templates used for those clients. I need to hyperlink each mention of a template in every document to its corresponding template document, which are all stored in a template folder.
I have a excel spread sheet with 2 columns. The 1st being the name of the template, the 2nd being a hyperlink to that template in the relevant folder.
Below is the script I have created but I am having issues getting it to hyperlink the text, I have tried the code written here with some changed to search and replace with my variable but it makes them all the same hyperlink. https://superuser.com/a/1010293
I am struggling to find another way to do this based on my current knowledge of VBA.
Below is my current code which carries out the whole task.
Public strArray() As String
Public LinkArray() As String
Public TotalRows As Long
Sub Hyperlink()
Dim file
Dim path As String
Dim FilenameWaterMark As String
Call OpenExcelFile
i = 1
For i = 1 To TotalRows
'here I need the document to look through while searching for strarray(I)
'and make that string a hyperlink to linkarray(I)
Next
ActiveDocument.Save
End Sub
Sub OpenExcelFile()
'Variables
Dim i, x As Long
Dim oExcel As Excel.Application
Dim oWB As Workbook
i = 1
'Opening Excel Sheet
Set oExcel = New Excel.Application
Set oWB = oExcel.Workbooks.Open("H:\DCTEST\Templates\DOCS.xlsx")
oExcel.Visible = True
'Counts Number of Rows in Sheet
TotalRows = Rows(Rows.Count).End(xlUp).Row
ReDim strArray(1 To TotalRows)
ReDim LinkArray(1 To TotalRows)
'Assigns each cell in Column A to an Array
For i = 1 To TotalRows
strArray(i) = Cells(i, 1).Value
Next
'searches for hyperlink
For i = 1 To TotalRows
LinkArray(i) = Cells(i, 2).Value
Next
oExcel.Quit
End Sub
I got it working myself. Below is the full code.
Dim strArray() As String
Dim LinkArray() As String
Dim TotalRows As Long
Private Sub DOCUMENT_OPEN()
Dim file
Dim path As String
Dim FilenameWaterMark As String
Dim Rng As Range
Dim SearchString As String
Dim EndString As String
Dim Id As String
Dim Link As String
Call OpenExcelFile
i = 1
For i = 1 To TotalRows
Set Rng = ActiveDocument.Range
SearchString = strArray(i)
With Rng.Find
.MatchWildcards = False
Do While .Execute(findText:=SearchString, Forward:=False, MatchWholeWord:=True) = True
Rng.MoveStartUntil (strArray(i))
Rng.MoveEndUntil ("")
Link = LinkArray(i)
ActiveDocument.Hyperlinks.Add Anchor:=Rng, _
Address:=Link, _
SubAddress:="", ScreenTip:="", TextToDisplay:=Rng.Text
Rng.Collapse wdCollapseStart
Loop
End With
Next
ActiveDocument.Save
End Sub
Sub OpenExcelFile()
'Variables
Dim i, x As Long
Dim oExcel As Excel.Application
Dim oWB As Workbook
i = 1
'Opening Excel Sheet
Set oExcel = New Excel.Application
Set oWB = oExcel.Workbooks.Open("H:\DCTEST\Templates\DOCS.xlsx")
oExcel.Visible = False
'Counts Number of Rows in Sheet
TotalRows = Rows(Rows.Count).End(xlUp).Row
ReDim strArray(1 To TotalRows)
ReDim LinkArray(1 To TotalRows)
'Assigns each cell in Column A to an Array
For i = 1 To TotalRows
strArray(i) = Cells(i, 1).Value
Next
'searches for hyperlink
For i = 1 To TotalRows
LinkArray(i) = Cells(i, 2).Value
Next
oExcel.Quit
End Sub
This runs when the document is open and links all mentions of a template to its document in the template folder.
I'm trying to get a spreadsheet that will import data from another file, scan the file for certain values in column D and then paste specific cells (not the whole row) into the first row that has a blank cell in column F in the new spreadsheet.
This is my updated code now
Sub GetAmazonData()
Dim counter As Integer
Dim LastRow As Long
Dim Adspend As Workbook
Dim A As String
Dim Amazon As Workbook
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Set Adspend = ActiveWorkbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Specify data export file
A = Application.GetOpenFilename(Title:="Select File To Be Processed")
Set Amazon = Application.Workbooks.Open(A)
counter = 2
' While Not Amazon.Worksheets(1).Range("D" & counter) = ""
If Amazon.Worksheets(1).Range("D" & counter) = "B01GB3HZ34" Then
Set targetSheet = Adspend.Worksheets("DirtyDom")
Set sourceSheet = Amazon.Worksheets(1)
LastRow = Adspend.Worksheets("DirtyDom").Cells(Adspend.Worksheets("DirtyDom").Rows.Count, "F").End(xlUp).Row
targetSheet.Range("F" & LastRow).Value = sourceSheet.Range("D" & counter).Value
Else
LastRow = Adspend.Worksheets("DirtyDom").Cells(Adspend.Worksheets("DirtyDom").Rows.Count, "F").End(xlUp).Row
targetSheet.Range("F" & LastRow).Value = sourceSheet.Range("D4").Value
End If
' ActiveCell.Offset(1, 0).Active
' Wend
Amazon.Close
End Sub
I expect this bit of code to paste what is in the imported file's first sheet cell D1 into the sheet called DirtyDom in cell F1 since 1 is the first cell blank in column F.
I get the error Object variable or With block variable not set.
Thank you!
Try something like this, it also puts your loop back in and resets your screen updating and alerts - untested.
Sub GetAmazonData()
Dim Adspend As Workbook
Dim Amazon As Workbook
Dim Targetsheet As Worksheet
Dim Amazonsheet As Worksheet
Dim Amazonfilename As String
Dim lastAmazonrow As Long
Dim lastTargetrow As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Adspend = ActiveWorkbook
Set Targetsheet = Adspend.Worksheets("DirtyDom")
'Specify data export file
Amazonfilename = Application.GetOpenFilename(Title:="Select File To Be Processed")
Set Amazon = Application.Workbooks.Open(Amazonfilename)
Set Amazonsheet = Amazon.Worksheets(1)
lastAmazonrow = Amazonsheet.Cells(Amazonsheet.Rows.Count, "D").End(xlUp).Row
lastTargetrow = Targetsheet.Cells(Targetsheet.Rows.Count, "F").End(xlUp).Row + 1
For counter = 1 To lastAmazonrow
If Amazonsheet.Range("D" & counter) = "B01GB3HZ34" Then
Targetsheet.Range("F" & lastTargetrow).Value = Amazonsheet.Range("D" & counter).Value
Else
Targetsheet.Range("F" & lastTargetrow).Value = Amazonsheet.Range("D4").Value
End If
lastTargetrow = lastTargetrow + 1
Next i
Amazon.Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
For some reason when I am writing my datatable to excel I am getting the below error message. It appears that the error is happening within my second for loop.
Exception from HRESULT: 0x800A03EC
Public Shared Sub ExportExcel(ByVal dt As DataTable)
Try
Dim strFile As String = MYFilelocation
Dim excel As New Microsoft.Office.Interop.Excel.ApplicationClass
Dim wBook As Microsoft.Office.Interop.Excel.Workbook
Dim wSheet As Microsoft.Office.Interop.Excel.Worksheet
wBook = excel.Workbooks.Add()
wSheet = wBook.ActiveSheet()
Dim dc As System.Data.DataColumn
Dim dr As System.Data.DataRow
Dim colIndex As Integer = 0
Dim rowIndex As Integer = 0
For Each dc In dt.Columns
colIndex = colIndex + 1
excel.Cells(1, colIndex) = dc.ColumnName
Next
For Each dr In dt.Rows
rowIndex = rowIndex + 1
colIndex = 0
For Each dc In dt.Columns
colIndex = colIndex + 1
excel.Cells(rowIndex + 1, colIndex) = dr(dc.ColumnName)
Next
Next
wSheet.Columns.AutoFit()
wBook.SaveAs(strFile)
wBook.Close()
Catch ex As Exception
MessageBox.Show("there was an issue Exporting to Excel" & ex.ToString)
End Try
End Sub
Try this:
Dim workbook = New ExcelFile
Dim worksheet = workbook.Worksheets.Add("DataTable to Sheet")
Dim dataTable = New DataTable
dataTable.Columns.Add("ID", Type.GetType("System.Int32"))
dataTable.Columns.Add("FirstName", Type.GetType("System.String"))
dataTable.Columns.Add("LastName", Type.GetType("System.String"))
dataTable.Rows.Add(New Object() {100, "John", "Doe"})
dataTable.Rows.Add(New Object() {101, "Fred", "Nurk"})
dataTable.Rows.Add(New Object() {103, "Hans", "Meier"})
dataTable.Rows.Add(New Object() {104, "Ivan", "Horvat"})
dataTable.Rows.Add(New Object() {105, "Jean", "Dupont"})
dataTable.Rows.Add(New Object() {106, "Mario", "Rossi"})
worksheet.Cells(0, 0).Value = "DataTable insert example:"
' Insert DataTable to an Excel worksheet.
worksheet.InsertDataTable(dataTable,
New InsertDataTableOptions() With
{
.ColumnHeaders = True,
.StartRow = 2
})
workbook.Save("DataTable to Sheet.xlsx")
I have tried many methods to create multiple Excel files required for my project. But all are slow down the process. Ultimately, I found that this is the fastest method to create Excel files.
Imports:
Imports DocumentFormat.OpenXml.Packaging
Add references to project
WindowsBase
DocumentFormat.OpenXml
Install-Package DocumentFormat.OpenXml
Full Code:
Private Sub ExportDataSet(ByVal DataTable_In As DataTable, ByVal Destination As String, Optional ds As DataSet = Nothing)
Dim FileName As String = "ExcelFileName" & ".xlsx"
Using workbook = SpreadsheetDocument.Create(Destination & "\" & FileName, DocumentFormat.OpenXml.SpreadsheetDocumentType.Workbook)
Dim workbookPart = workbook.AddWorkbookPart()
workbook.WorkbookPart.Workbook = New DocumentFormat.OpenXml.Spreadsheet.Workbook()
workbook.WorkbookPart.Workbook.Sheets = New DocumentFormat.OpenXml.Spreadsheet.Sheets()
If Not DataTable_In Is Nothing Then
Dim sheetPart = workbook.WorkbookPart.AddNewPart(Of WorksheetPart)()
Dim sheetData = New DocumentFormat.OpenXml.Spreadsheet.SheetData()
sheetPart.Worksheet = New DocumentFormat.OpenXml.Spreadsheet.Worksheet(sheetData)
Dim sheets As DocumentFormat.OpenXml.Spreadsheet.Sheets = workbook.WorkbookPart.Workbook.GetFirstChild(Of DocumentFormat.OpenXml.Spreadsheet.Sheets)()
Dim relationshipId As String = workbook.WorkbookPart.GetIdOfPart(sheetPart)
Dim sheetId As UInteger = 1
If sheets.Elements(Of DocumentFormat.OpenXml.Spreadsheet.Sheet)().Count() > 0 Then
sheetId = sheets.Elements(Of DocumentFormat.OpenXml.Spreadsheet.Sheet)().[Select](Function(s) s.SheetId.Value).Max() + 1
End If
Dim sheet As DocumentFormat.OpenXml.Spreadsheet.Sheet = New DocumentFormat.OpenXml.Spreadsheet.Sheet() With {
.Id = relationshipId,
.SheetId = sheetId,
.Name = DataTable_In.TableName
}
sheets.Append(sheet)
Dim headerRow As DocumentFormat.OpenXml.Spreadsheet.Row = New DocumentFormat.OpenXml.Spreadsheet.Row()
Dim columns As List(Of String) = New List(Of String)()
For Each column As System.Data.DataColumn In DataTable_In.Columns
columns.Add(column.ColumnName)
Dim cell As DocumentFormat.OpenXml.Spreadsheet.Cell = New DocumentFormat.OpenXml.Spreadsheet.Cell()
cell.DataType = DocumentFormat.OpenXml.Spreadsheet.CellValues.String
cell.CellValue = New DocumentFormat.OpenXml.Spreadsheet.CellValue(column.ColumnName)
headerRow.AppendChild(cell)
Next
sheetData.AppendChild(headerRow)
For Each dsrow As System.Data.DataRow In DataTable_In.Rows
Dim newRow As DocumentFormat.OpenXml.Spreadsheet.Row = New DocumentFormat.OpenXml.Spreadsheet.Row()
For Each col As String In columns
Dim cell As DocumentFormat.OpenXml.Spreadsheet.Cell = New DocumentFormat.OpenXml.Spreadsheet.Cell()
cell.DataType = DocumentFormat.OpenXml.Spreadsheet.CellValues.String
cell.CellValue = New DocumentFormat.OpenXml.Spreadsheet.CellValue(dsrow(col).ToString())
newRow.AppendChild(cell)
Next
sheetData.AppendChild(newRow)
Next
Else
For Each table As System.Data.DataTable In ds.Tables
Dim sheetPart = workbook.WorkbookPart.AddNewPart(Of WorksheetPart)()
Dim sheetData = New DocumentFormat.OpenXml.Spreadsheet.SheetData()
sheetPart.Worksheet = New DocumentFormat.OpenXml.Spreadsheet.Worksheet(sheetData)
Dim sheets As DocumentFormat.OpenXml.Spreadsheet.Sheets = workbook.WorkbookPart.Workbook.GetFirstChild(Of DocumentFormat.OpenXml.Spreadsheet.Sheets)()
Dim relationshipId As String = workbook.WorkbookPart.GetIdOfPart(sheetPart)
Dim sheetId As UInteger = 1
If sheets.Elements(Of DocumentFormat.OpenXml.Spreadsheet.Sheet)().Count() > 0 Then
sheetId = sheets.Elements(Of DocumentFormat.OpenXml.Spreadsheet.Sheet)().[Select](Function(s) s.SheetId.Value).Max() + 1
End If
Dim sheet As DocumentFormat.OpenXml.Spreadsheet.Sheet = New DocumentFormat.OpenXml.Spreadsheet.Sheet() With {
.Id = relationshipId,
.SheetId = sheetId,
.Name = table.TableName
}
sheets.Append(sheet)
Dim headerRow As DocumentFormat.OpenXml.Spreadsheet.Row = New DocumentFormat.OpenXml.Spreadsheet.Row()
Dim columns As List(Of String) = New List(Of String)()
For Each column As System.Data.DataColumn In table.Columns
columns.Add(column.ColumnName)
Dim cell As DocumentFormat.OpenXml.Spreadsheet.Cell = New DocumentFormat.OpenXml.Spreadsheet.Cell()
cell.DataType = DocumentFormat.OpenXml.Spreadsheet.CellValues.String
cell.CellValue = New DocumentFormat.OpenXml.Spreadsheet.CellValue(column.ColumnName)
headerRow.AppendChild(cell)
Next
sheetData.AppendChild(headerRow)
For Each dsrow As System.Data.DataRow In table.Rows
Dim newRow As DocumentFormat.OpenXml.Spreadsheet.Row = New DocumentFormat.OpenXml.Spreadsheet.Row()
For Each col As String In columns
Dim cell As DocumentFormat.OpenXml.Spreadsheet.Cell = New DocumentFormat.OpenXml.Spreadsheet.Cell()
cell.DataType = DocumentFormat.OpenXml.Spreadsheet.CellValues.String
cell.CellValue = New DocumentFormat.OpenXml.Spreadsheet.CellValue(dsrow(col).ToString())
newRow.AppendChild(cell)
Next
sheetData.AppendChild(newRow)
Next
Next
End If
End Using
End Sub
is it possible to read a webpage from a hyperlink in excel and directly count the readability scores, ampersands and exclamations from the webpage without query the data back into excel by changing this VBA code? Also it is possible from a file path? This is all in one spreadsheet.
Option Compare Text
Sub Display_Stylometric_Scores()
Dim Words As String
Dim Characters As String
Dim Paragraphs As String
Dim Sentences As String
Dim Sentences_per_paragraph As String
Dim Words_per_sentence As String
Dim Characters_per_word As String
Dim Ratio_of_passive_sentences As String
Dim Flesch_Reading_Ease_score As String
Dim Flesch_Kincaid_Grade_Level_score As String
Dim Coleman_Liau_Readability_Score As String
Dim Ampersands As Long
Dim Exclamations As Long
Dim row As Integer
Dim column As Integer
Dim ActiveDocument As Object
Dim RS As Object
Dim txt As String
row = 3
Set ActiveDocument = CreateObject("Word.Document")
Do While Worksheets("Sample_Output_2").Cells(row, 1) <> ""
txt = Worksheets("Sample_Output_2").Cells(row, 2).Value
ActiveDocument.Content = txt
Set RS = ActiveDocument.Content.ReadabilityStatistics
Words = RS(1).Value
Characters = RS(2).Value
Paragraphs = RS(3).Value
Sentences = RS(4).Value
Sentences_per_paragraph = RS(5).Value
Words_per_sentence = RS(6).Value
Characters_per_word = RS(7).Value
Ratio_of_passive_sentences = RS(8).Value
Flesch_Reading_Ease_score = RS(9).Value
Flesch_Kincaid_Grade_Level_score = RS(10).Value
Ampersands = CountChar(txt, "&")
Exclamations = CountChar(txt, "!")
Worksheets("Sample_Output_2").Cells(row, 4).Resize(1, 12).Value =
Array(Words, Characters, Paragraphs, Sentences, Sentences_per_paragraph, _
Words_per_sentence, Characters_per_word, Ratio_of_passive_sentences, _
Flesch_Reading_Ease_score, Flesch_Kincaid_Grade_Level_score, _
Ampersands, Exclamations)
row = row + 1
Loop
End Sub
Function CountChar(txt As String, char As String) As Long
CountChar = Len(txt) - Len(Replace(txt, char, ""))
End Function
Yes, you an use MXSML to make an http request. Here's an example and a little refactoring of your existing code
Sub Main()
Dim vaWrite As Variant
Dim hDoc As MSHTML.HTMLDocument
Dim xHttp As MSXML2.XMLHTTP
'Set a reference to MSXML2
'Open a webpage using GET
Set xHttp = New MSXML2.XMLHTTP
xHttp.Open "GET", "http://stackoverflow.com/questions/15103048/count-data-on-webpage-from-url-in-excel-vba"
xHttp.send
'Wait for the web page to finish loading
Do Until xHttp.readyState = 4
DoEvents
Loop
'If the web page rendered properly
If xHttp.Status = 200 Then
'Create a new HTMLdocument
Set hDoc = New MSHTML.HTMLDocument
'Put the GET response into the doc's body
hDoc.body.innerHTML = xHttp.responseText
'Get an array back containing the readability scores
vaWrite = Display_Stylometric_Scores(hDoc.body.innerText)
'Write that array to a worksheet
Sheet1.Range("A2").Resize(UBound(vaWrite, 1), UBound(vaWrite, 2)).Value = vaWrite
End If
End Sub
Function Display_Stylometric_Scores(ByRef sText As String) As Variant
Dim aReadStats(1 To 1, 1 To 12) As Double
Dim wdDoc As Object
Dim wdRs As Object
Dim i As Long
Dim vaSpecial As Variant
Const lMAXIDX As Long = 10
vaSpecial = Array("&", "!")
Set wdDoc = CreateObject("Word.Document")
wdDoc.Content = sText
Set wdRs = wdDoc.Content.ReadabilityStatistics
For i = 1 To lMAXIDX
aReadStats(1, i) = wdRs(i).Value
Next i
For i = LBound(vaSpecial) To UBound(vaSpecial)
aReadStats(1, lMAXIDX + 1 + i) = CountChar(sText, vaSpecial(i))
Next i
Display_Stylometric_Scores = aReadStats
End Function
Function CountChar(ByRef sText As String, ByVal sChar As String) As Long
CountChar = Len(sText) - Len(Replace(sText, sChar, vbNullString))
End Function