How to export date column to excel in correct format via ExcelLibrary - excel

I am exporting multiple DataTables to an Excel-file using ExcelLiabrary. The problem is that date column in all datatables, are being exported as number. DataTables are filled with data retrieved from Sql Server where the column type is date. Datagrids are also showing it correctly but in the excel it become numbers.
Here is the code to populate DataTable
Dim command = New SqlCommand("getdeta", sqlConn)
command.CommandType =
CommandType.StoredProcedure
Dim adapter = New SqlDataAdapter(command)
dt1 = New DataTable()
adapter.Fill(dt1)
dgv1.DataSource = dt1
and here is to Export data to Excel
Dim fileName = ExportAllDialog.FileName
datasetForExport.Tables.Add(dt1)
datasetForExport.Tables.Add(dt2)
ExcelLibrary.DataSetHelper.CreateWorkbook(fileName, datasetForExport)

So here is some code for the Microsoft.Office.Interop.Excel approach:
Option Strict On
Option Explicit On
Imports System.IO
Imports System.Runtime.InteropServices
Imports Excel = Microsoft.Office.Interop.Excel
Public Class ExcelBook
Private EXL As Excel.Application
Private Book As Excel.Workbook
Private Sheet As Excel.Worksheet
Private MyFileName As String
Protected Overrides Sub Finalize()
' Save and close the currently loaded Excel file
Close(True)
' Delete the local reference to the app BEFORE destroy
EXL = Nothing
MyBase.Finalize()
End Sub
Private Sub OpenApplication()
If EXL IsNot Nothing Then Return
EXL = New Excel.Application
EXL.Visible = False
EXL.DisplayAlerts = False
End Sub
Public Sub Open(Filename As String)
Open(Filename, 1)
End Sub
Public Sub Open(Filename As String, SheetIndex As Object)
OpenApplication()
' If another Excel file is open, close it
Close(True)
If File.Exists(Filename) Then
Book = EXL.Workbooks.Open(Filename)
Else
Book = EXL.Workbooks.Add()
End If
' Turns off warning messages when saving older files
Book.CheckCompatibility = False
UseSheet(SheetIndex)
MyFileName = Filename
End Sub
Public Sub Close(Save As Boolean)
If Book Is Nothing Then Return
If File.Exists(MyFileName) Then
Book.Close(Save)
Else
If Save Then Book.SaveAs(MyFileName)
Book.Close()
End If
Sheet = Nothing
Book = Nothing
MyFileName = Nothing
End Sub
Public Function UseSheet(Index As Object) As Boolean
If Book Is Nothing Then Return False
Try
Sheet = DirectCast(Book.Sheets(Index), Excel.Worksheet)
Sheet.Activate()
Return True
Catch Ex As COMException
Return False
End Try
End Function
Public Sub AddSheet(NewName As String)
AddSheet(NewName, Nothing)
End Sub
Public Sub AddSheet(NewName As String, Before As Object)
If Book Is Nothing Then Return
If SheetExists(NewName) Then Return
If Before Is Nothing OrElse Not SheetExists(Before) Then
Sheet = CType(Book.Sheets.Add(After:=Book.Sheets(Book.Sheets.Count)), Excel.Worksheet)
Else
Sheet = CType(Book.Sheets.Add(Before:=Book.Sheets(Before)), Excel.Worksheet)
End If
Sheet.Activate()
Sheet.Name = NewName
End Sub
Function SheetExists(Index As Object) As Boolean
If Book Is Nothing Then Return False
Dim LocalSheet As Excel.Worksheet
Try
LocalSheet = DirectCast(Book.Sheets(Index), Excel.Worksheet)
Catch Ex As COMException
LocalSheet = Nothing
End Try
Return LocalSheet IsNot Nothing
End Function
Public Sub RenameSheet(NewName As String)
If Sheet Is Nothing Then Return
If Not String.IsNullOrEmpty(NewName) Then Sheet.Name = NewName
End Sub
Public Sub FormatColumns(Columns As String, NewFormat As String)
If Sheet Is Nothing Then Return
Dim Rng = DirectCast(Sheet.Columns(Columns), Excel.Range)
Rng.NumberFormat = NewFormat
End Sub
Public Sub ImportTable(Table As DataTable)
If Sheet Is Nothing Then Return
If Table Is Nothing Then Return
If Table.Columns.Count = 0 Then Return
Dim Matrix(Table.Rows.Count, Table.Columns.Count) As Object
Dim Col As Integer
' Copy the datatable to an array
For Row As Integer = 0 To Table.Rows.Count - 1
For Col = 0 To Table.Columns.Count - 1
Matrix(Row, Col) = Table.Rows(Row).Item(Col)
Next
Next
' Add the column headers starting in A1
Col = 0
For Each Column As DataColumn In Table.Columns
Sheet.Cells(1, Col + 1) = Column.ColumnName
Col += 1
Next
' Add the data starting in cell A2
If Table.Rows.Count > 0 Then
Sheet.Range(Sheet.Cells(2, 1), Sheet.Cells(Table.Rows.Count + 1, Table.Columns.Count)).Value = Matrix
End If
End Sub
End Class
Then you could use this function to export your DataSet:
Private Sub ExportDataSet(DS As DataSet, Filename As String)
Dim DT As DataTable
Dim First As Boolean = True
With New ExcelBook
.Open(Filename)
For Each DT In DS.Tables
If First Then
.RenameSheet(DT.TableName)
First = False
Else
.AddSheet(DT.TableName)
End If
.ImportTable(DT)
Next
.UseSheet(1)
.Close(True)
End With
End Sub

Related

Read from Excel - write to CSV in different column order

I need to understand if there is a possibility, within VB.NET, to be able to read the columns of an Excel file and write them out to a CSV file in a different order.
In practice, the Excel file we are sent has 6 columns: "amount", "branch", stock "," proposal "," quantity "," type ". The company management system accepts the text file with the columns in a different order: "branch", "stock", "amount", "quantity", "type", "proposal". This creates a problem for me because when I go to convert it my ERP fails to recognize that the column is in a different position.
I arrive at the concrete question, I would like to have the possibility to read the columns and make it possible through a script to be able to position them according to the position I decide.
I tried this code for import and convert to txt, but I need another script:
Imports System.IO
Imports ExcelDataReader
Imports System.Text
Public Class Form1
Dim tables As DataTableCollection
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
Using ofd As OpenFileDialog = New OpenFileDialog() With {.Filter = "(*.xls)|*.xls|(*.xls)|*.xlsx"}
If ofd.ShowDialog() = DialogResult.OK Then
txtFileName.Text = ofd.FileName
Using Stream = File.Open(ofd.FileName, FileMode.Open, FileAccess.Read)
Using reader As IExcelDataReader = ExcelReaderFactory.CreateReader(Stream)
Dim result As DataSet = reader.AsDataSet(New ExcelDataSetConfiguration() With {
.ConfigureDataTable = Function(__) New ExcelDataTableConfiguration() With {
.UseHeaderRow = True}})
tables = result.Tables
cboSheet.Items.Clear()
For Each table As DataTable In tables
cboSheet.Items.Add(table.TableName)
Next
End Using
End Using
End If
End Using
End Sub
Private Sub cboSheet_SelectedIndexChanged(sender As Object, e As EventArgs) Handles cboSheet.SelectedIndexChanged
Dim dt As DataTable = tables(cboSheet.SelectedItem.ToString())
dgProposte.DataSource = dt
End Sub
Private Sub Button2_Click(sender As Object, e As EventArgs) Handles Button2.Click
Dim writer As TextWriter = New StreamWriter("C:\Users\antonio\Desktop\Prova.txt")
For i As Integer = 0 To dgProposte.Rows.Count - 2 Step +1
For j As Integer = 0 To dgProposte.Columns.Count - 1 Step +1
writer.Write(vbTab & dgProposte.Rows(i).Cells(j).Value.ToString() & vbTab & "")
Next
writer.WriteLine("")
Next
writer.Close()
MessageBox.Show("Dati Esportati")
End Sub
The tables that you get from importing the Excel sheet(s) have their column names set, and you can index the column by its name.
So, and with a little adjustment to factor out some methods:
Imports System.IO
Imports ExcelDataReader
Public Class Form1
Dim tables As DataTableCollection
Private Sub WriteToCsv(tableName As String, filename As String)
Dim columnWriteOrder = {"branch", "stock", "amount", "quantity", "type", "proposal"}
Using writer As TextWriter = New StreamWriter(filename)
Dim tbl = tables(tableName)
For i As Integer = 0 To dgProposte.Rows.Count - 2
Dim vals As New List(Of String)
For j As Integer = 0 To columnWriteOrder.Length - 1
Dim val = tbl.Rows(i).Item(columnWriteOrder(j)).ToString()
vals.Add(val)
Next
writer.WriteLine(String.Join(vbTab, vals))
Next
End Using
End Sub
Private Sub PopulateSheetNames()
cboSheet.Items.Clear()
For Each table As DataTable In tables
cboSheet.Items.Add(table.TableName)
Next
End Sub
Private Sub cboSheet_SelectedIndexChanged(sender As Object, e As EventArgs) Handles cboSheet.SelectedIndexChanged
If cboSheet.SelectedIndex >= 0 Then
Dim tableName = cboSheet.SelectedItem.ToString()
Dim dt As DataTable = tables(tableName)
dgProposte.DataSource = dt
End If
End Sub
Private Sub bnLoad_Click(sender As Object, e As EventArgs) Handles bnLoad.Click
Using ofd As OpenFileDialog = New OpenFileDialog() With {.Filter = "(*.xlsx)|*.xlsx|(*.xls)|*.xls", .InitialDirectory = "C:\temp"}
If ofd.ShowDialog() <> DialogResult.OK Then
Exit Sub
End If
txtFileName.Text = ofd.FileName
Using Stream = File.Open(ofd.FileName, FileMode.Open, FileAccess.Read)
Using reader As IExcelDataReader = ExcelReaderFactory.CreateReader(Stream)
Dim edsc = New ExcelDataSetConfiguration() With {
.ConfigureDataTable = Function(__) New ExcelDataTableConfiguration() With {
.UseHeaderRow = True}}
Dim result As DataSet = reader.AsDataSet(edsc)
tables = result.Tables
End Using
End Using
PopulateSheetNames()
End Using
End Sub
Private Sub bnSaveAsCsv_Click(sender As Object, e As EventArgs) Handles bnSaveAsCsv.Click
If cboSheet.SelectedIndex < 0 Then
MessageBox.Show("Please select a sheet name.", "No sheet name selected", MessageBoxButtons.OK, MessageBoxIcon.Information)
Exit Sub
End If
Dim sheetName = cboSheet.SelectedItem.ToString()
If Not String.IsNullOrEmpty(sheetName) Then
WriteToCsv(sheetName, "C:\temp\Prova.csv")
MessageBox.Show("Dati Esportati.", "Dati Esportati", MessageBoxButtons.OK, MessageBoxIcon.Information)
End If
End Sub
End Class
I changed the names of the buttons because "Button1" and "Button2" are not descriptive.
(I set the .InitialDirectory of the OpenFileDialog because it was convenient for me.)
Why you don't map a DTO of your data table?
Public Class MioDto
Property campoUno As String
Property campoDue As String
'...ecc
End Class
and then you can fill a dto in a cicle or so...
Dim a As New MioDto() With {.campoUno="...", campoDue="..."}
or if you want you can use
https://github.com/AutoMapper/AutoMapper
When you have a Dto class filled you can use it for generate your txt with youor preferred order.

Can't properly close Excel application

i am very new to VB.net and i'm trying to proceed step by step with my application.
The application i'm trying to build will collect a series of macros i've written in Excel VBA environment.
Now, the following code pasted below, is the initial part, where basically i try to load a workbook (to be used as Active workbook) and to "unload it".
The issue comes when, after "unloading" the workbook, i try to open the very same workbook in excel.
Excel application return an error that is "Open in read-only". This cannot be accepted, and i need to understand how to unload the workbook and release it from the myAPP.
Imports Excel = Microsoft.Office.Interop.Excel
Public Class Form1
Dim workbook As Excel.Workbook
Dim worksheet As Excel.Worksheet
Dim APP As New Excel.Application
Private Sub opn_btn_Click(sender As Object, e As EventArgs) Handles opn_btn.Click
Dim strname As String
Dim cellname As String
With OpenFileDialog1
.InitialDirectory = "E:\Vs_Excel"
.Title = "Open xlsx file"
.ShowDialog()
End With
workbook = APP.Workbooks.Open(OpenFileDialog1.FileName)
worksheet = workbook.Worksheets("sheet1")
cellname = worksheet.Range("A1").Value
strname = OpenFileDialog1.FileName
Me.TextBox1.Text = strname
Me.TextBox2.Text = cellname
Dim lvwReport As View = View.List
With Me.ListView1
.GridLines = True
.View = lvwReport
.CheckBoxes = True
End With
'LoadListView() 'thi sroutine is written but not used yet. Must solve first the problem wioth closing ExcelApplication
End Sub
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
workbook.Close()
APP.Quit()
Me.TextBox1.Text = ""
Me.TextBox2.Text = ""
ReleaseObject(worksheet)
worksheet = Nothing
ReleaseObject(workbook)
workbook = Nothing
ReleaseObject(APP)
APP = Nothing
End Sub
Private Sub ReleaseObject(ByVal obj As Object)
Try
Dim intRel As Integer = 0
Do
intRel = System.Runtime.InteropServices.Marshal.ReleaseComObject(obj)
Loop While intRel > 0
MsgBox("Final Released obj # " & intRel)
Catch ex As Exception
MsgBox("Error releasing object" & ex.ToString)
obj = Nothing
Finally
GC.Collect()
End Try
End Sub
End class

How to make a Search Filter in Excel VBA that displays search result in the ListBox while typing a word?

I'm trying to make an Advanced Search now for weeks in my Userform where it will filter and display the result on the ListBox while typing a value. But somehow my ComboBox that serves as a filter has a dropdown function already.
I have no idea how can I make it like the way I wanted it.
My UserForm contains 8 columns.
Here is the existing code for the ComboBox filter
Private Sub cmbSearch_Change()
'The function of this code below is for the user to click a value from the ComboBox and then the result will be displayed on the TextBoxes and ListBox.
x = Sheets("DATA STOCK").Range("A" & Rows.Count).End(xlUp).Row
For y = 2 To x
If Sheets("DATA STOCK").Cells(y, 1).Text = cmbSearch.Value Then
cmbSchema.Text = Sheets("DATA STOCK").Cells(y, 1)
cmbEnvironment.Text = Sheets("DATA STOCK").Cells(y, 2)
cmbHost.Text = Sheets("DATA STOCK").Cells(y, 3)
cmbIP.Text = Sheets("DATA STOCK").Cells(y, 4)
cmbAccessible.Text = Sheets("DATA STOCK").Cells(y, 5)
cmbLast.Text = Sheets("DATA STOCK").Cells(y, 6)
cmbConfirmation.Text = Sheets("DATA STOCK").Cells(y, 7)
cmbProjects.Text = Sheets("DATA STOCK").Cells(y, 8)
UserForm1.listHeader.RowSource = "A" + CStr(y) + ": H" + CStr(y)
Exit For
End If
Next y
End Sub
Expected Result:
User types word in the ComboBox (I have selected ComboBox as a filter because of its dropdown function)
While the user is typing, it will show the result to the ListBox.
The problem is I don't know how to create that kind of search filter and if it is possible even though I already have a dropdown function in my ComboBox
Saw that you've been working for weeks on this.
I have refactored your form's code and implemented the functionality you've been looking for.
As my other answer to your other question, in my opinion it's easier to work adding and removing items to the listbox, rather than working with excel ranges. (How to fix this bug in my code that doesn't allow me to update other columns in excel userform?)
Important remarks:
- I've converted the data inside the sheet to an Excel Structured Table (Ctrl + T)
- I took one of your previous files, so the information you have inside the table may be out of date
- Testing I also modified some of the data
- I suggest you copy and paste your most recent data and replace it inside the table
Here you can download the file based on your data:
https://github.com/rdiazjimenez/excel-vba-userform-basic-listbox-demo/blob/master/MDM_DB_Checking_09122018_RD.xlsm
I covered basic operations (Create, Read, Update, Delete and Search/Filter) with Excel Data loaded into a Listbox inside a Userform.
This is the code behind the form:
Option Explicit
' Code updated
Private Sub btnDelete_Click()
Application.EnableEvents = False
Call mCode.Delete
Application.EnableEvents = True
End Sub
' Code updated
Private Sub btnView_Click()
Application.EnableEvents = False
Call mCode.Read
Application.EnableEvents = True
End Sub
' Code updated
Private Sub cmbAdd_Click()
Application.EnableEvents = False
Call mCode.Create
Application.EnableEvents = True
End Sub
' Code updated
Private Sub cmbClearFields_Click()
Application.EnableEvents = False
Call mCode.ClearControls
Application.EnableEvents = True
End Sub
' Code updated
Private Sub cmbSearch_Change()
Application.EnableEvents = False
Call FilterList(Me.listHeader, Me.cmbSearch.Text)
Application.EnableEvents = True
End Sub
' Code updated
Private Sub cmbUpdate_Click()
Application.EnableEvents = False
Call mCode.Update
Application.EnableEvents = True
End Sub
' Code updated
Private Sub CommandButton5_Click()
Application.EnableEvents = False
Call mCode.ClearList
Application.EnableEvents = True
End Sub
' Code from this event was removed
Private Sub listHeader_Click()
End Sub
' Code added
Private Sub listHeader_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Application.EnableEvents = False
Call mCode.LoadControls
Application.EnableEvents = True
End Sub
' Code partially updated
Private Sub UserForm_Initialize()
Me.cmbSearch.List = ThisWorkbook.Sheets("PRESTAGE DB").ListObjects("TableData").ListColumns(1).DataBodyRange.Value
Me.cmbEnvironment.AddItem "DEV"
Me.cmbEnvironment.AddItem "UAT"
Me.cmbEnvironment.AddItem "SIT"
Me.cmbEnvironment.AddItem "QA"
Me.cmbEnvironment.AddItem "PROD"
Me.cmbAccessible.AddItem "Y"
Me.cmbAccessible.AddItem "N"
Me.cmbIP.AddItem "1521"
Me.cmbProjects.AddItem "DP - proposed for DEV/SIT"
Me.cmbProjects.AddItem "PH EFUSE SIT"
Me.cmbProjects.AddItem "MyAXA SG DEV/DIT"
End Sub
And this is the code inside a module called mCode:
Option Explicit
' Global variables
Const sheetName As String = "PRESTAGE DB"
Const tableName As String = "TableData"
Public Sub ShowUserForm()
oUserForm.Show
End Sub
Public Sub Read()
' Comments: Loads the data from an excel table (listobject) into a listbox located inside a userform
' Params :
' Notes : Adapt the initialize variables section
' Created : 2019/01/25 RD www.ricardodiaz.co
' Modified:
' Define objects variables
Dim myUserForm As oUserForm ' Note: you're defining the variable as the class of the userform. This gives you access to the userform's controls later
Dim myListObject As Excel.listObject
Dim myRange As Excel.Range
' Define other variables
Dim columnCount As Integer
Dim selectedItem As Integer
Dim rowCounter As Long
Dim columnCounter As Integer
'''''''' Initialize objects ''''''''
' Init the userform
' Note: When you initialize it directly with the name of the form, you can access the controls of the userform too
Set myUserForm = oUserForm
' Load the data from the Excel table into a range variable
' Note: It's safer to refer to thisworkbook
Set myListObject = ThisWorkbook.Worksheets(sheetName).ListObjects(tableName)
'''''''' Initialize variables ''''''''
myUserForm.listHeader.ColumnWidths = "130 pt;60 pt;82 pt;55 pt;70 pt;195 pt;170 pt;130 pt"
' Set the number of columns to the same of the table in the Excel sheet
columnCount = myListObject.ListColumns.Count
' Get the current selected item
selectedItem = myUserForm.listHeader.ListIndex ' this returns -1 if none is selected
' Clear the listbox contents
Call mCode.ClearList
' Set the number of columns to load into the listbox
myUserForm.listHeader.columnCount = columnCount
' Loop through each row and load it into the listbox
' Note: begins with 2 because the first row are the table headers
For rowCounter = 2 To myListObject.Range.Rows.Count
With myUserForm.listHeader
.AddItem
' Load value of each column in the table row
For columnCounter = 0 To columnCount
.List(rowCounter - 2, columnCounter) = myListObject.Range.Cells(rowCounter, columnCounter + 1).Value
Next columnCounter
End With
Next
' Select previously selected row
If selectedItem < myUserForm.listHeader.ListCount Then
myUserForm.listHeader.ListIndex = selectedItem
End If
' Clean up objects
Set myListObject = Nothing
Set myUserForm = Nothing
End Sub
Public Sub Create()
' Comments: Adds a new row with the data entered by the user and reloads the listbox inside the userform
' Params :
' Notes : Adapt the initialize variables section
' Created : 2019/01/25 RD www.ricardodiaz.co
' Modified:
' Define objects variables
Dim myUserForm As oUserForm ' Note: you're defining the variable as the class of the userform. This gives you access to the userform's controls later
Dim myListObject As Excel.listObject
Dim myListRow As Excel.listRow
'''''''' Initialize objects ''''''''
' Init the userform
' Note: When you initialize it directly with the name of the form, you can access the controls of the userform too
Set myUserForm = oUserForm
' Add the information to the Excel table
Set myListObject = ThisWorkbook.Worksheets(sheetName).ListObjects(tableName)
' Validate if all the information is correct
If myUserForm.cmbEnvironment.Text = vbNullString _
Or myUserForm.cmbHost.Text = vbNullString _
Or myUserForm.cmbIP.Text = vbNullString _
Or myUserForm.cmbAccessible.Text = vbNullString _
Or myUserForm.cmbLast.Text = vbNullString Then
MsgBox "Some fields cannot be blank!", vbCritical, "Data Missing"
Exit Sub
End If
' Add a blank row at the end of the Excel table
Set myListRow = myListObject.ListRows.Add
' Set the information into de excel table
With myListRow
.Range(1) = myUserForm.cmbSchema.Text
.Range(2) = myUserForm.cmbEnvironment.Text
.Range(3) = myUserForm.cmbHost.Text
.Range(4) = myUserForm.cmbIP.Text
.Range(5) = myUserForm.cmbAccessible.Text
.Range(6) = myUserForm.cmbLast.Text
.Range(7) = myUserForm.cmbConfirmation.Text
.Range(8) = myUserForm.cmbProjects.Text
End With
MsgBox "Data Added!"
' Reload the data into the listbox
Call mCode.Read
' Select the last item in the listbox
myUserForm.listHeader.ListIndex = myUserForm.listHeader.ListCount - 1
' Clear control's contents
Call ClearControls ' Note that this is a private procedure inside the mCode module
' Clean up objects
Set myListRow = Nothing
Set myListObject = Nothing
Set myUserForm = Nothing
End Sub
Public Sub Update()
' Comments: Updates a row with the data entered by the user and reloads the listbox inside the userform
' Params :
' Notes : Adapt the initialize variables section
' Created : 2019/01/25 RD www.ricardodiaz.co
' Modified:
' Define objects variables
Dim myUserForm As oUserForm ' Note: you're defining the variable as the class of the userform. This gives you access to the userform's controls later
Dim myListObject As Excel.listObject
Dim myListRow As Excel.listRow
' Define variables
Dim selectedItem As Integer
'''''''' Initialize objects ''''''''
' Init the userform
' Note: When you initialize it directly with the name of the form, you can access the controls of the userform too
Set myUserForm = oUserForm
' Add the information to the Excel table
Set myListObject = ThisWorkbook.Worksheets(sheetName).ListObjects(tableName)
' Define selected row number
selectedItem = myUserForm.listHeader.ListIndex + 1
' Exit if there are no other rows
If selectedItem = 0 Then
MsgBox "There are no rows left!"
Exit Sub
End If
' Initialize the row at the end of the Excel table
Set myListRow = myListObject.ListRows(selectedItem)
' the following section is exactly as the Create procedure, so you theorically could make just one procedure for Create and Update
' Set the information into de excel table
With myListRow
.Range(2) = myUserForm.cmbEnvironment.Text
.Range(3) = myUserForm.cmbHost.Text
.Range(4) = myUserForm.cmbIP.Text
.Range(5) = myUserForm.cmbAccessible.Text
.Range(6) = myUserForm.cmbLast.Text
.Range(7) = myUserForm.cmbConfirmation.Text
.Range(8) = myUserForm.cmbProjects.Text
End With
' Reload the data into the listbox
Call mCode.Read
' Select the updated item in the listbox
myUserForm.listHeader.ListIndex = selectedItem - 1
MsgBox "Data Updated!"
' Clear control's contents
Call ClearControls ' Note that this is a private procedure inside the mCode module
' Clean up objects
Set myListRow = Nothing
Set myListObject = Nothing
Set myUserForm = Nothing
End Sub
Public Sub Delete()
' Comments: Deletes a row with the data entered by the user and reloads the listbox inside the userform
' Params :
' Notes : Adapt the initialize variables section
' Created : 2019/01/25 RD www.ricardodiaz.co
' Modified:
' Define objects variables
Dim myUserForm As oUserForm ' Note: you're defining the variable as the class of the userform. This gives you access to the userform's controls later
Dim myListObject As Excel.listObject
Dim myListRow As Excel.listRow
' Define variables
Dim selectedItem As Integer
'''''''' Initialize objects ''''''''
' Init the userform
' Note: When you initialize it directly with the name of the form, you can access the controls of the userform too
Set myUserForm = oUserForm
' Add the information to the Excel table
Set myListObject = ThisWorkbook.Worksheets(sheetName).ListObjects(tableName)
' Define selected row number
selectedItem = myUserForm.listHeader.ListIndex + 1
' Exit if there are no other rows
If selectedItem = 0 Then
MsgBox "There are no rows left or you didn't select a valid row!"
Exit Sub
End If
If MsgBox("Are you sure you want to delete this row?", vbYesNo + vbQuestion, "Yes") = vbNo Then
Exit Sub
End If
' Initialize the row at the end of the Excel table
Set myListRow = myListObject.ListRows(selectedItem)
' Delete the row
myListRow.Delete
' Reload the data into the listbox
Call mCode.Read
' Select the next item in the listbox
myUserForm.listHeader.ListIndex = WorksheetFunction.Min(selectedItem - 1, myUserForm.listHeader.ListCount) - 1
' Clean up objects
Set myListRow = Nothing
Set myListObject = Nothing
Set myUserForm = Nothing
End Sub
Public Sub ClearList()
' Comments: Clear the listbox
' Define objects variables
Dim myUserForm As oUserForm
' Init the userform
' Note: When you initialize it directly with the name of the form, you can access the controls of the userform too
Set myUserForm = oUserForm
myUserForm.listHeader.Clear
End Sub
Public Sub LoadControls()
' Comments: Loads the selected row's data into the controls
' Define objects variables
Dim myUserForm As oUserForm
Dim selectedItem As Integer
' Init the userform
' Note: When you initialize it directly with the name of the form, you can access the controls of the userform too
Set myUserForm = oUserForm
' Get the row of the selected item in the listbox
selectedItem = myUserForm.listHeader.ListIndex
' Set the control's text to each column of the selected item
myUserForm.cmbSchema.Value = myUserForm.listHeader.List(selectedItem, 0)
myUserForm.cmbEnvironment.Value = myUserForm.listHeader.List(selectedItem, 1)
myUserForm.cmbHost.Value = myUserForm.listHeader.List(selectedItem, 2)
myUserForm.cmbIP.Value = myUserForm.listHeader.List(selectedItem, 3)
myUserForm.cmbAccessible.Value = myUserForm.listHeader.List(selectedItem, 4)
myUserForm.cmbLast.Value = myUserForm.listHeader.List(selectedItem, 5)
myUserForm.cmbConfirmation.Value = myUserForm.listHeader.List(selectedItem, 6)
myUserForm.cmbProjects.Value = myUserForm.listHeader.List(selectedItem, 7)
' Clean up objects
Set myUserForm = Nothing
End Sub
Public Sub ClearControls()
' Comments: Reset controls to empty strings
' Define objects variables
Dim myUserForm As oUserForm
' Init the userform
' Note: When you initialize it directly with the name of the form, you can access the controls of the userform too
Set myUserForm = oUserForm
' Clear the controls
myUserForm.cmbSchema.Text = vbNullString
myUserForm.cmbEnvironment.Text = vbNullString
myUserForm.cmbHost.Text = vbNullString
myUserForm.cmbIP.Text = vbNullString
myUserForm.cmbAccessible.Text = vbNullString
myUserForm.cmbLast.Text = vbNullString
myUserForm.cmbConfirmation.Text = vbNullString
myUserForm.cmbProjects.Text = vbNullString
' Clean up objects
Set myUserForm = Nothing
End Sub
Public Sub FilterList(oLb As MSForms.ListBox, strFiltro As String)
Dim columnCounter As Integer
Dim listString As String
Dim rowCounter As Integer
oLb.ListIndex = -1
' Read the whole list
Call mCode.Read
' Remove unmatching items
For rowCounter = oLb.ListCount - 1 To 0 Step -1
listString = vbNullString
' Concat the list columns values in one string
For columnCounter = 0 To oLb.columnCount
listString = listString & oLb.Column(columnCounter, rowCounter)
Next columnCounter
If InStr(1, listString, strFiltro, 1) = 0 Then
' Remove items that don't match
oLb.RemoveItem rowCounter
End If
Next
End Sub
Something like so?
Private Sub TextBox1_Change()
Dim strID As String
Dim lngRow As Long
Dim a As Variant
strID = TextBox1.Text
On Error GoTo eHandle
lngRow = WorksheetFunction.Match(strID, Range("a1:a10"), 0)
On Error GoTo 0
If lngRow > 0 Then
Me.ListBox1.RowSource = ""
Me.ListBox1.ColumnCount = 4
Me.ListBox1.ColumnWidths = "20;20;20;20"
Me.ListBox1.RowSource = "Sheet1!a" & lngRow & ":d" & lngRow
End If
Exit Sub
eHandle:
lngRow = 0
Resume Next
End Sub
Private Sub UserForm_Click()
End Sub

VB.NET: Excel Crashes when Updating Data in a Word Chart

Update: Releasing objects has no effect on Excel crashing. The problematic line is:
Dim wChartData = wChart.ChartData
I have written a VB.Net application that opens a word document, iterates through the inline shapes, and updates each chart with data from the database. Sometimes Excel will crash when opening the sheet containing the chart data. Can anyone tell me how I fix this?
Here is the code that iterates through the shapes:
wApp = New Word.Application
wApp.Visible = True
wDoc = wApp.Documents.Add("Some_File_Name.docx")
Console.WriteLine("Updating Charts")
Dim chartName As String
For Each wShape As Word.InlineShape In wDoc.InlineShapes
If wShape.HasChart = Core.MsoTriState.msoTrue Then
If wShape.Chart.HasTitle Then
chartName = wShape.Chart.ChartTitle.Text
Else
chartName = "NO_TITLE"
End If
UpdateChart(wShape.Chart, reportID, reportTitle,
reportUser, curriculumYear, chartName)
End If
Next
The UpdateChart subroutine grabs a SQL query and some options related to the chart, then fires off the FillChartData subroutine below:
Public Sub FillChartData(ByRef wChart As Word.Chart, ByVal sql As String,
Optional ByVal addDataPointsToLabels As Boolean = False)
If sql = "" Then Exit Sub
Dim cmd = O.factory.CreateCommand()
cmd.CommandText = sql
cmd.Connection = O.con
O.factory.CreateDataAdapter()
Dim adapter = O.factory.CreateDataAdapter
adapter.SelectCommand = cmd
Dim dt As New System.Data.DataTable()
Dim ds As New System.Data.DataSet()
adapter.Fill(ds, "report_name")
dt = ds.Tables(0)
Dim wChartData = wChart.ChartData
Dim wChartWb As Excel.Workbook = wChartData.Workbook
Dim wChartSheet As Excel.Worksheet = wChartWb.Sheets(1)
Dim title As String = "No title"
If wChart.HasTitle Then title = wChart.ChartTitle.Text.ToString
Dim r As Excel.Range
r = wChartSheet.Range("A1")
r.CurrentRegion.Clear()
For i = 0 To dt.Columns.Count - 1
Dim c As System.Data.DataColumn = dt.Columns(i)
r.Offset(0, i).Value2 = c.ColumnName
Next
r = wChartSheet.Range("A2")
For Each row As System.Data.DataRow In dt.Rows
For i = 0 To row.ItemArray.Count - 1
r.Offset(0, i).Value2 = row.Item(i)
Next
r = r.Offset(1)
Next
r = wChartSheet.Range("A1")
If addDataPointsToLabels Then
While r.Value <> ""
r.Value &= " " & r.Offset(1).Value
r = r.Offset(0, 1)
End While
End If
wChartWb.Close()
releaseObject(r)
releaseObject(wChartSheet)
releaseObject(wChartWb)
releaseObject(wChartData)
r = Nothing
wChartSheet = Nothing
wChartWb = Nothing
wChartData = Nothing
GC.Collect()
End Sub
The releaseObject subroutine is as follows:
Private Sub releaseObject(ByVal obj As Object)
Try
System.Runtime.InteropServices.Marshal.ReleaseComObject(obj)
obj = Nothing
Catch ex As Exception
MessageBox.Show(ex.ToString)
obj = Nothing
End Try
End Sub
And here's the crash report:
Problem signature:
Problem Event Name: APPCRASH
Application Name: EXCEL.EXE
Application Version: 15.0.5007.1000
Application Timestamp: 5a5eb36d
Fault Module Name: EXCEL.EXE
Fault Module Version: 15.0.5007.1000
Fault Module Timestamp: 5a5eb36d
Exception Code: c0000005
Exception Offset: 002b71c8
OS Version: 6.1.7601.2.1.0.256.4
Locale ID: 1033
Additional information about the problem:
LCID: 1033
skulcid: 1033
Read our privacy statement online:
http://go.microsoft.com/fwlink/?linkid=104288&clcid=0x0409
If the online privacy statement is not available, please read our privacy statement offline:
C:\Windows\system32\en-US\erofflps.txt
Thanks for your help!
You need to Activate the Word ChartData object to begin the inter-process communication between Word and Excel.
The example below is a simplified demonstration of code pattern and contains no error handling. This example also demonstrates releasing out of scope COM objects via the garbage collector. See this answer for more discussion on this COM clean-up procedure.
This code was verified against Office 2007.
Imports System.Runtime.InteropServices
Imports Excel = Microsoft.Office.Interop.Excel
Imports Word = Microsoft.Office.Interop.Word
Public Class Form1
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
InterOpWork("Embedded Excel Chart.docx")
COMCleanup()
End Sub
Sub InterOpWork(filePath As String)
Dim appWord As New Word.Application
Dim doc As Word.Document = appWord.Documents.Open((filePath))
Dim shp As Word.InlineShape = doc.InlineShapes(1)
Dim ch As Word.Chart = shp.Chart
Dim chData As Word.ChartData = ch.ChartData
chData.Activate() ' **** This is what your code is missing
Dim wb As Excel.Workbook = DirectCast(chData.Workbook, Excel.Workbook)
Dim appExcel As Excel.Application = DirectCast(wb.Application, Excel.Application)
Dim ws As Excel.Worksheet = DirectCast(wb.Worksheets("Sheet1"), Excel.Worksheet)
Dim rng As Excel.Range = ws.Range("B2:B4")
Dim dataToChange As Object(,) = DirectCast(rng.Value2, Object(,))
For i As Int32 = dataToChange.GetLowerBound(0) To dataToChange.GetUpperBound(0)
dataToChange(i, 1) = i * 2 + (5 - i)
Next
rng.Value = dataToChange
wb.Save()
wb.Close(False)
appExcel.Quit()
doc.Save()
doc.Close(False)
appWord.Quit()
End Sub
Private Sub COMCleanup()
Do
GC.Collect()
GC.WaitForPendingFinalizers()
Loop While Marshal.AreComObjectsAvailableForCleanup
End Sub
End Class

VBA module call in userform to diff sheets

new and would like to ask if someone could possibly check my code to see where i'm making a mistake.
first, i've created a form with two textboxes and two buttons that will go and get two different directories and the associated files. this is done through a call to a function that loads the dir to the textboxes.
a button to call a function to navigate dir and get the file
Private Sub CommandButton3_Click()
'call selectFile function to select file
selectFile
End Sub
function to get workbooks into textboxes 1 and 2:
Public Function selectFile()
Dim fileNamePath1 As String
Dim fileNamePath2 As String
Dim workbookFilePath1 As String
Dim workbookFilePath2 As String
On Error GoTo exit_
If workbookFilePath1 = Empty And workbookFilePath2 = Empty Then
fileNamePath1 = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls), *.xls", Title:="Open Workbook 1", MultiSelect:=False)
workbookFilePath1 = Dir(fileNamePath1)
'TextBox1.Text = workbookFilePath1
TextBox1.Value = fileNamePath1
fileNamePath2 = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls), *.xls", Title:="Open Workbook 2", MultiSelect:=False)
workbookFilePath2 = Dir(fileNamePath2)
TextBox2.Value = fileNamePath2
If fileNamePath1 = False Or fileNamePath2 = False Then
MsgBox ("File selection was canceled.")
Exit Function
End If
End If
exit_:
End Function
up to here, the code is ok... can do better, but
here's where problems occur... i'd like to pass the directories as objects into the module to diff
button that executes module to diff:
Private Sub CommandButton1_Click()
getTheWorkbooksToCompare(fileNamePath1, fileNamePath2)
End Sub
i know that i've changed myPath1 and myPath2 to Workbooks, where I've had them as strings before
diffing module
Public Sub gettheWorkbooksToCompare(myPath1 As Workbook, myPath2 As Workbook)
Dim myExcelObj
Dim WorkbookObj1
Dim WorkbookObj2
Dim WorksheetObj1
Dim WorksheetObj2
Dim file1 As String
Dim file2 As String
Dim myWorksheetCounter As Integer
Dim i As Worksheet
Set myExcelObj = CreateObject("Excel.Application")
myExcelObj.Visible = True
Set file1 = Dir(myPath1)
Set file2 = Dir(myPath2)
Set WorkbookObj1 = myExcelObj.Workbooks.Open(file1)
Set WorkbookObj2 = myExcelObj.Workbooks.Open(file2)
Set NewWorkbook = myExcelObj.Workbooks.Add
While WorkbookObj1 <> Null And WorkbookObj2 <> Null
'While WorkbookObj1.ActiveWorkbook.Worksheets.count = WorkbookOjb2.ActiveWorkbook.Worksheets.count
myWorksheetCounter = ActiveWorkbook.Worksheets.count
myWorksheetCount = ActiveWorkbook.Worksheets.count
If WorksheetObj1.Worksheets.myWorksheetCounter = WorkbookObj2.Worksheets.myWorksheetCounter Then
Set WorksheetObj1 = WorkbookObj1.Worksheets(myWorksheetCounter)
Set WorksheetObj2 = WorkbookObj2.Worksheets(myWorksheetCounter)
Set myNewWorksheetObj = NewWorkbook.Worksheets(myWorksheetCounter)
For myWorksheetCounter = i To WorksheetObj1
For myWorksheetCount = j To WorksheetOjb2
'If cell.Value myWorksheetObj2.Range(cell.Address).Value Then
If cell.Value = myWorksheetObj2.Range(cell.address).Value Then
myNewWorksheetObj.Range(cell.address).Value = cell.address.Value
myNewWorksheetObj.Range(cell.address).Interior.ColorIndex = 3
Else
cell.Interior.ColorIndex = 0
End If
Next
'if doesn't work... use SaveChanges = True
myNewWorksheetObj.Workbooks.Save() = True
Next
Else
MsgBox ("The worksheets are not the same worksheets." & vbNewLine & "Please try again.")
End If
Wend
Set myExcelObj = Nothing
End Sub
So my question is... can someone please assist in seeing where i'm going wrong? essentially, i'm having some issues in trying to get this working.
much appreciated
i've gone through and cleaned up some areas a little bit... but now have a: "run time error '438': object doesn't support this propety or method" at the while loop code that i've updated the post with
I see a typo on CommandButton1_Click
Private Sub CommandButton1_Click()
getTheWorkbooksToCompare(fileNamePath1, fileNamePath2)
End Sub
Public Sub gettheWorkbooksToCompare(myPath1 As Workbook, myPath2 As Workbook)
There might be something more, but your not capitalizing the "T" in getThe, but you call it that way.

Resources