I'm a beginner in VBA and so would appreciate some help. I'm trying to build a directory to display results based on user selection of 'category' and 'subcategory'. When I run the script, there is no error message but I don't see any results displayed. Is there anything wrong with my code?
Sub Button5_Click()
'''Function to search data set
Dim wkbk As Workbook
Dim row_data As Range
Dim results_ws As Worksheet, data_ws As Worksheet
Dim n_row As Integer '''counter for row number
Dim main_ws As Worksheet
Dim category As String, subcategory As String
Set wkbk = ThisWorkbook
Set results_ws = wkbk.Sheets("Demo_Results")
Set data_ws = wkbk.Sheets("Demo_Data")
Set main_ws = ThisWorkbook.Sheets("Demo_Main")
'''Clear the results worksheet
results_ws.Cells.ClearContents
results_ws.Hyperlinks.Delete
results_ws.Cells.Font.Underline = False
results_ws.Columns("B:E").Font.Color = RGB(0, 0, 0)
category = main_ws.Cells(13, "F").Value
subcategory = main_ws.Cells(15, "F").Value
result_count = 0
final_data_row = data_ws.Range("A1000").End(xlUp).Row
For n_row = 2 To final_data_row:
If data_ws.Cells(n_row, "A") = category And data_ws.Cells(n_row, "B") = subcategory Then
With data_ws
Set row_data = data_ws.Range(data_ws.Cells(n, 1), data_ws.Cells(n, 7))
result_count = result_count + 1
results_ws.Cells(Rows.Count, "E").End(xlUp).Offset(2, -3).Value = Str(result_count) + ".)"
results_ws.Cells(Rows.Count, "E").End(xlUp).Offset(2, -2).Value = row_data.Cells(1, 3).Value
'''Enter state
results_ws.Cells(Rows.Count, "C").End(xlUp).Offset(1, 1).Value = "State:"
results_ws.Cells(Rows.Count, "D").End(xlUp).Offset(0, 1).Value = row_data.Cells(1, 4).Value
End With
End If
Next n_row
'''Format table
Sheets("Demo_Results").Select
Call ResetFormatting
ActiveWindow.ScrollRow = 1
End Sub
Function ResetFormatting():
'''Resent font style and size for results column
Dim wsheet As Worksheet
Set wsheet = ThisWorkbook.Sheets("Demo_Results")
wsheet.Cells.Font.Name = "Verdana"
wsheet.Cells.Font.Size = 11
End Function
Related
I'm trying to write a script that does three things. Finds all cells in a range that have a "x" in them, then takes those cells and references a reference sheet, then delivering an output.
In a more specific way, Worksheet "data sheet":
takes all the "x" cells and then retrieves information using the column headers from row 5 as the key against a reference sheet:
and output in this format:
At this point forget about the reference issue, I can't get the worksheet to output correctly. I'm getting a compile error. I'm hoping from there I can get the reference to work.
Sub Decentral_Role_Output_Actor_Role()
Dim myWB As Workbook
Dim i As Integer
Dim UNameColumn As Integer
Dim RoleColumn As Integer
Dim name As String
Dim counter As Long
counter = 3
Set myWB = ThisWorkbook
Worksheets("Reference Output").Range("A:F").ClearContents
UNameColumn = 3
RoleColumn = 5
AddRole = 4
'Set column headers
'METADATA|User|CredentialsEmailSent|PersonNumber|Username
'METADATA|UserRole|PersonNumber|AddRemoveRole|RoleCommonName
Worksheets("Reference Output").Cells(1, 1) = "METADATA"
Worksheets("Reference Output").Cells(1, 2) = "User"
Worksheets("Reference Output").Cells(1, 3) = "CredentialsEmailSent"
Worksheets("Reference Output").Cells(1, 4) = "PersonNumber"
Worksheets("Reference Output").Cells(1, 5) = "Username"
Worksheets("Reference Output").Cells(2, 1) = "METADATA"
Worksheets("Reference Output").Cells(2, 2) = "UserRole"
Worksheets("Reference Output").Cells(2, 4) = "AddRemoveRole"
Worksheets("Reference Output").Cells(2, RoleColumn) = "RoleCommonName"
Worksheets("Reference Output").Cells(2, UNameColumn) = "PersonNumber"
For Each Cell In Worksheets("Data Sheet").Range("H6:N" & LastRow)
If Cell.Value = "x" Then
Worksheets("Reference Output").Cells(counter, UNameColumn).Value = UCase(name)
Worksheets("Reference Output").Cells(counter, RoleColumn) = "ORA_GL"
Worksheets("Reference Output").Cells(counter, 1) = "MERGE"
Worksheets("Reference Output").Cells(counter, 2) = "UserRole"
Worksheets("Reference Output").Cells(counter, 4) = "ADD"
counter = counter + 1
End If
Next Cell
MsgBox "Role Access Output created at " & myWB.Path
End Sub
Like mentioned, I'm getting a compile error.
Result of trying the new script
Result of new script after changing Reference to "Reference Sheet"
Try this out (untested):
Option Explicit
Sub Decentral_Role_Output_Actor_Role()
Const UNameColumn As Long = 3 'use const for fixed values
Const AddRole As Long = 4
Const RoleColumn As Long = 5
Dim wb As Workbook, wsRO As Worksheet, wsData As Worksheet
Dim name As String, actor As String, secCode, cell As Range
Dim counter As Long, LastRow As Long, wsRef As Worksheet
Set wb = ThisWorkbook
Set wsRO = wb.Worksheets("Reference Output") 'use worksheet references
Set wsData = wb.Worksheets("Data Sheet")
Set wsRef = wb.Worksheets("Reference") 'for example
'Column headers
'METADATA|User|CredentialsEmailSent|PersonNumber|Username
'METADATA|UserRole|PersonNumber|AddRemoveRole|RoleCommonName
With wsRO
.Range("A:F").ClearContents
.Range("A1").Resize(1, 5).Value = _
Array("METADATA", "User", "CredentialsEmailSent", _
"PersonNumber", "Username")
.Range("A1").Resize(1, 5).Value = _
Array("METADATA", "UserRole", "", "AddRemoveRole", "")
.Cells(2, UNameColumn).Value = "PersonNumber"
.Cells(2, RoleColumn).Value = "RoleCommonName"
End With
'Use a column which will be populated to the last row...
LastRow = wsData.Cells(Rows.Count, "A").End(xlUp).Row
counter = 3
For Each cell In wsData.Range("H6:N" & LastRow).Cells
If UCase(Trim(cell.Value)) = "X" Then 'edited
name = UCase(cell.EntireRow.Columns("F").Value) 'read name from same row
actor = wsData.Cells(5, cell.Column).Value 'read actor from header row
secCode = Application.VLookup(actor, wsRef.Range("A2:B5"), 2, False) 'lookup...
If IsError(secCode) Then secCode = "??????" 'if no match
With wsRO.Rows(counter) 'use a With to reduce code volume
.Cells(1) = "MERGE"
.Cells(2) = "UserRole"
.Cells(UNameColumn).Value = name
.Cells(counter, 4) = "ADD"
.Cells(RoleColumn) = secCode
End With
counter = counter + 1
End If
Next cell
MsgBox "Role Access Output created at " & wb.PATH
End Sub
I am relatively new to this coding. I am trying to add to my inventory database(in another sheet) if the model that is key into the activex textbox dose not match. If it matches, then it will automatically update to the quantity. However, I am getting error438. Here is the code that I have written so far.
Sub Add()
Dim invdata As Worksheet
Dim frm As Worksheet
Dim iqty As Integer
Set frm = ThisWorkbook.Sheets("UserForm")
Set invdata = ThisWorkbook.Sheets("Inventory Database")
iqty = frm.Range("B9")
Dim irow As Integer
Dim jrow As Integer
Dim i As Integer
If Application.WorksheetFunction.CountIf(invdata.Range("C:C"), ActiveSheet.tbModel.Value) > 0 Then
jrow = invdata.Range("A" & invdata.Rows.Count).End(xlUp).row + 1
With invdata
.Cells(jrow, 1).Value = frm.Range("B6").Value
.Cells(jrow, 2).Value = frm.Range("B7").Value
.Cells(jrow, 3).Value = ActiveSheet.tbModel.Value
.Cells(jrow, 4).Value = frm.Range("B9").Value
End With
MsgBox ("New Model Added!")
Else
irow = invdata.Cells(Rows.Count, 3).End(xlUp).row
For i = 2 To irow
If Sheet1.Cells(i, 3) = ActiveSheet.tbModel.Value Then
Sheet1.Cells(i, 4) = Sheet1.Cells(i, 4) + iqty
Exit Sub
End If
Next i
End If
End Sub
Try this - using Find() instead of CountIf() saves you from the loop:
Sub Add()
Dim invdata As Worksheet, frm As Worksheet, model, f As Range
Dim iqty As Long
Set frm = ThisWorkbook.Sheets("UserForm")
Set invdata = ThisWorkbook.Sheets("Inventory Database")
iqty = frm.Range("B9").Value
model = frm.OLEObjects("tbModel").Object.Value '####
'see if there's a match using `Find()`
Set f = invdata.Range("C:C").Find(what:=model, lookat:=xlWhole)
If f Is Nothing Then
'model was not found in Col C
With invdata.Range("A" & invdata.Rows.Count).End(xlUp).Offset(1)
.Value = frm.Range("B6").Value
.Offset(0, 1).Value = frm.Range("B7").Value
.Offset(0, 2).Value = model
.Offset(0, 3).Value = iqty
End With
MsgBox "New Model Added!"
Else
With f.EntireRow.Cells(4)
.Value = .Value + iqty ' update qty in row `m`
End With
End If
End Sub
I need the expert help in VBA Excel code. I need to find the number of duplicate record (AlertToString) for particular device serial number from the source sheet serial number and paste it to the other newly created output sheet by using VBA Macro.
Example (Source sheet):
Expected (Output Sheet with repeat Alert count) :
Source code as below :
Sub Alert700Count()
Dim AlertSource_Sh As Worksheet
Dim AlertOutput_Sh As Worksheet
'Insert a New Blank Worksheet
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("AlertOutput").Delete
Sheets.Add.Name = "AlertOutput"
Application.DisplayAlerts = True
Set AlertSource_Sh = ThisWorkbook.Sheets("SourceSheet")
Set AlertOutput_Sh = ThisWorkbook.Sheets("AlertOutput")
AlertOutput_Sh.Cells(1, 1) = "Serial No"
AlertOutput_Sh.Cells(1, 2) = "A92"
AlertOutput_Sh.Cells(1, 3) = "A95"
AlertOutput_Sh.Cells(1, 4) = "A98"
For Each sh In ActiveWorkbook.Worksheets
With sh.Range("A1:D1")
.Font.Bold = True
.WrapText = True
.CellWidth = 35
.Selection.Font.ColorIndex = 49
.Weight = xlMedium
.LineStyle = xlDash
End With
Next sh
AlertOutput_Sh.Range("A1:D1").Borders.Color = RGB(10, 201, 88)
AlertOutput_Sh.Columns("A:D").ColumnWidth = 12
AlertOutput_Sh.Range("A1:D1").Font.Color = rgbBlueViolet
AlertOutput_Sh.Range("A1:D1").Interior.Color = vbYellow
AlertOutput_Sh.Range("A1:D1").HorizontalAlignment = xlCenter
AlertOutput_Sh.Range("A1:D1").VerticalAlignment = xlTop
' Search the duplicate record and paste in output sheet
Dim A92Count As Long
A92Count = Application.CountIf(AlertSource_Sh.Range("D:D"), "A92")
AlertOutput_Sh.Cells(2, 2) = A92Count
Dim A95Count As Long
A95Count = Application.CountIf(AlertSource_Sh.Range("D:D"), "A95")
AlertOutput_Sh.Cells(2, 3) = A92Count
Dim A98Count As Long
A98Count = Application.CountIf(AlertSource_Sh.Range("D:D"), "A98")
AlertOutput_Sh.Cells(2, 4) = A98Count
End Sub
Current Output :
Use Dictionaries to build lists of unique values and an array to hold the counts.
Option Explicit
Sub Alert700Count()
Dim wsData As Worksheet, wsOut As Worksheet
Dim dictSerNo As Object, dictAlert As Object
Dim arData, arOut, k, rngOut As Range
Dim lastrow As Long, i As Long
Dim serNo As String, alert As String
Dim r As Long, c As Long, t0 As Single: t0 = Timer
Set dictSerNo = CreateObject("Scripting.Dictionary")
Set dictAlert = CreateObject("Scripting.Dictionary")
On Error Resume Next
Application.DisplayAlerts = False
Sheets("AlertOutput").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Sheets.Add.Name = "AlertOutput"
Set wsOut = Sheets("AlertOutput")
Set wsData = Sheets("SourceSheet")
r = 1: c = 1
With wsData
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
arData = .Range("A1:D" & lastrow).Value2
' get unique serno and alert
For i = 2 To lastrow
serNo = arData(i, 1)
alert = arData(i, 4)
If dictSerNo.exists(serNo) Then
ElseIf Len(serNo) > 0 Then
r = r + 1
dictSerNo.Add serNo, r
End If
If dictAlert.exists(alert) Then
ElseIf Len(alert) > 0 Then
c = c + 1
dictAlert.Add alert, c
End If
Next
' rescan for counts
ReDim arOut(1 To r, 1 To c)
For i = 2 To lastrow
r = dictSerNo(CStr(arData(i, 1)))
c = dictAlert(CStr(arData(i, 4)))
arOut(r, c) = arOut(r, c) + 1
Next
End With
' add headers
arOut(1, 1) = "Serial No"
' sernos and alerts
For Each k In dictSerNo
arOut(dictSerNo(k), 1) = k
Next
For Each k In dictAlert
arOut(1, dictAlert(k)) = k
Next
' output counts
With wsOut
Set rngOut = .Range("A1").Resize(UBound(arOut), UBound(arOut, 2))
rngOut.Value2 = arOut
rngOut.Replace "", 0
.ListObjects.Add(xlSrcRange, rngOut, , xlYes).Name = "Table1"
.Range("A1").AutoFilter
.Range("A1").Select
End With
MsgBox "Done", vbInformation, Format(Timer - t0, "0.0 secs")
End Sub
I have multiple worksheets and each sheet contains skill details.
Sample data
Skills Name
Programs(C#, VB, Python) C#
OS(Windows, Linux)
DB(Oracle, SQL) Oracle
My requirement is, if user put skills as "Programs(C#, VB, Python)", then return next cell value i.e. "C#"
My code.
Private Sub BtnReport_Click()
Dim SkillName As String
Dim SkillRng As Range
Dim rng As Range
'Dim nextblankrow As Long
'Dim lastrow As Long
Dim x As Long
Dim y As Long
Dim val As String
SkillName = ActiveWorkbook.Worksheets("Admin").Range("L4")
If SkillName = "" Then
MsgBox "Select a skill name"
Exit Sub
End If
'Sheets(2).Select
'Set rng = Sheets(2).Range("B14:B100").Find(What:=SkillName)
'MsgBox rng.Value
Sheets("Report").Select
Sheets("Report").Cells.ClearContents
Sheets("Report").Cells(1, 1) = "Skill Name"
Sheets("Report").Cells(1, 2) = "Resource"
'''''For i = 1 To Sheets.Count - 1
''''' Set rng = Sheets(i).Range("B14:C100")
''''' Set SkillRng = rng.Find(What:=SkillName)
''''' If Not SkillRng Is Nothing Then
''''' Sheets("Report").Cells(i + 1, 1) = SkillRng.Value
''''' MsgBox rng.Cells.Value
'''''' Sheets("Report").Cells(i + 1, 2) = rng.Offset(RowoffSet = 1, Columnoffset = 2).Value
'''''' Sheets("Report").Cells(i + 1, 2) = SkillRng.Cells(Selection.Row, Selection.Column + 1).Value
''''' Sheets("Report").Cells(i + 1, 3) = ActiveWorkbook.Worksheets(i).name
''''' End If
'''''Next i
Set rng = Sheets(2).Range("B14:C100")
Set SkillRng = rng.Find(What:=SkillName)
For x = 1 To rng.Rows.Count
For y = 1 To rng.Columns.Count
If rng.Cells(x, y) = SkillRng Then
' Sheets("Report").Cells(2, 2) = rng.Cells(x, y + 1)
MsgBox SkillRng
MsgBox x
MsgBox y
val = Cells(x, y).Value
' val = SkillRng
MsgBox val
End If
Next y
Next x
I believe this will give you everything with little editing for sheet numbers and intended Report cell values
There is difference between sheets and worksheets. Sheets also include charts. So for your purpose use worksheets. Also, you have to skip the Report and Admin Worksheets for evaluation in the loop. If your report and Admin worksheets are (1) and (2) then start loop from 3. If you loop also evaluates these sheets and if it finds skillname in range to find (rng) in these sheets values from these sheets will also appear in your report.
Private Sub BtnReport_Click()
Dim SkillName As String
Dim SkillRng As Range
Dim rng As Range
SkillName = ActiveWorkbook.Worksheets("Admin").Range("L4")
If SkillName = "" Then
MsgBox "Select a skill name"
Exit Sub
End If
Sheets("Report").Select
Sheets("Report").Cells.ClearContents
Sheets("Report").Cells(1, 1) = "Skill Name"
Sheets("Report").Cells(1, 2) = "Resource"
For i = 1 To Worksheets.Count
Set rng = Worksheets(i).Range("B14:C100")
Set SkillRng = rng.Find(What:=SkillName)
k = Sheets("Report").Range("A1").CurrentRegion.Rows.Count + 1
If Not SkillRng Is Nothing Then
Sheets("Report").Cells(k, 1) = SkillName
Sheets("Report").Cells(k, 2) = SkillRng.Value
Sheets("Report").Cells(k, 3) = SkillRng.offset(0,1)
Sheets("Report").Cells(k, 4) = Worksheets(i).name
End If
Next i
End sub
I'm trying to export DataGridView items to Excel file and everything perfect, but I want the gridlines appear when the client want to print the sheet, I can do this from inside excel as shown here.
but how can I do this from the vb.net code ??
and I have a problem that : I cant make the text Alignment center I tried this code:
wSheet.Range("a2", "z1000").HorizontalAlignment = excel.XlVAlign.xlVAlignCenter
but it show this error: Public member 'XlVAlign' on type 'ApplicationClass' not found.
Is there a different way to make all columns Alignment center.
this Is my code :
If ((DataGridView1.Columns.Count = 0) Or (DataGridView1.Rows.Count = 0)) Then
Exit Sub
End If
'Creating dataset to export
Dim dset As New DataSet
'add table to dataset
dset.Tables.Add()
'add column to that table
For i As Integer = 0 To DataGridView1.ColumnCount - 1
If DataGridView1.Columns(i).Visible = True Then
dset.Tables(0).Columns.Add(DataGridView1.Columns(i).HeaderText)
End If
Next
Dim celltext As String
Dim count As Integer = -1
'add rows to the table
Dim dr1 As DataRow
For i As Integer = 0 To DataGridView1.RowCount - 1
dr1 = dset.Tables(0).NewRow
For j As Integer = 0 To DataGridView1.Columns.Count - 1
If DataGridView1.Columns(j).Visible = True Then
count = count + 1
dr1(count) = DataGridView1.Rows(i).Cells(j).Value
End If
Next
count = -1
dset.Tables(0).Rows.Add(dr1)
Next
Dim excel As New Excel.Application
Dim wBook As Excel.Workbook
Dim wSheet As Excel.Worksheet
wBook = excel.Workbooks.Add()
wSheet = wBook.ActiveSheet()
Dim dt As System.Data.DataTable = dset.Tables(0)
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()
' for the header
wSheet.Rows(1).Font.Name = "Droid Arabic Kufi"
wSheet.Rows(1).Font.size = 11
wSheet.Rows(1).Font.Bold = True
wSheet.Rows(1).HorizontalAlignment = HorizontalAlignment.Right
Dim mycol As System.Drawing.Color = System.Drawing.ColorTranslator.FromHtml("#20b2aa")
wSheet.Rows(1).Font.color = mycol
' for all the sheet without header
wSheet.Range("a2", "z1000").Font.Name = "Droid Arabic Kufi"
wSheet.Range("a2", "z1000").Font.Size = 10
wSheet.Range("a2", "z1000").HorizontalAlignment = excel.XlVAlign.xlVAlignCenter
wSheet.Range("A1:X1").EntireColumn.AutoFit()
wSheet.Range("A1:X1").EntireRow.AutoFit()
Dim saveFileDialog1 As New SaveFileDialog()
saveFileDialog1.Filter = "Excel Workbook|*.xls|Excel Workbook 2011|*.xlsx"
saveFileDialog1.Title = "Save Excel File"
saveFileDialog1.FileName = "Export " & Now.ToShortDateString & ".xlsx"
saveFileDialog1.ShowDialog()
saveFileDialog1.InitialDirectory = "C:/"
If saveFileDialog1.FileName <> "" Then
Dim fs As System.IO.FileStream = CType(saveFileDialog1.OpenFile(), System.IO.FileStream)
fs.Close()
End If
Dim strFileName As String = saveFileDialog1.FileName
Dim blnFileOpen As Boolean = False
Try
Dim fileTemp As System.IO.FileStream = System.IO.File.OpenWrite(strFileName)
fileTemp.Close()
Catch ex As Exception
blnFileOpen = False
Exit Sub
End Try
If System.IO.File.Exists(strFileName) Then
System.IO.File.Delete(strFileName)
End If
wBook.SaveAs(strFileName)
excel.Workbooks.Open(strFileName)
excel.Visible = True
Exit Sub
errorhandler:
MsgBox(Err.Description)
End Sub
And Is there a way to make rows In different color like row 1 background color blue Row 2 background color white, row 2 background color blue Row 4 background color ...etc
Note :
what is the default :
what I want :
First change the following code:
wSheet.Range("a2", "z1000").HorizontalAlignment = excel.XlVAlign.xlVAlignCenter
TO
wSheet.Range("a2", "z1000").HorizontalAlignment = excel.XlHAlign.xlHAlignCenter
Cell font color , size
Dim formatRange As Excel.Range
formatRange = xlWorkSheet.Range("b1", "b1")
formatRange.Font.Color = System.Drawing.ColorTranslator.ToOle(System.Drawing.Color.Red)
formatRange.Font.Size = 10
xlWorkSheet.Cells(1, 2) = "Red"
Add border to a specific cell
Dim formatRange As Excel.Range = xlWorkSheet.UsedRange
Dim cell As Excel.Range = formatRange.Cells(3, 3)
Dim border As Excel.Borders = cell.Borders
border.LineStyle = Excel.XlLineStyle.xlContinuous
border.Weight = 2.0
Border around multiple cells in excel
Dim formatRange As Excel.Range = wSheet.UsedRange
Dim cell As Excel.Range = wSheet.Range("a1", "e" & DataGridView1.RowCount & "")
Dim border As Excel.Borders = cell.Borders
border.LineStyle = Microsoft.Office.Interop.Excel.XlLineStyle.xlContinuous
border.Weight = 2.0
Read more in this Article
Thank to H.Fadlallah for helping me
This the answer:
make Gridlines to the excel sheet :
Dim formatRange As Excel.Range = wSheet.UsedRange
Dim cell As Excel.Range = wSheet.Range("a1", "j" & DataGridView1.RowCount + 1 & "")
Dim border As Excel.Borders = cell.Borders
border.LineStyle = Microsoft.Office.Interop.Excel.XlLineStyle.xlContinuous
border.Weight = 1.0
And this code to make Alignment center :
wSheet.Range("a2", "z1000").HorizontalAlignment = Microsoft.Office.Interop.Excel.XlHAlign.xlHAlignCenter
And this is the All Code To export DataGridView To Excel:
Button code :
Private Sub To_Excel_picbox_but_Click(sender As Object, e As EventArgs) Handles To_Excel_picbox_but.Click
Try
Dim day As Integer = Date.Today.Day
Dim month As Integer = Date.Today.Month
Dim year As Integer = Date.Today.Year
SaveFileDialog1.Filter = "Excel File|*.xlsx"
SaveFileDialog1.Title = "Save an Excel File"
SaveFileDialog1.FileName = " الحوالات المرسلة" & day & "-" & month & "-" & year & ".xlsx"
SaveFileDialog1.InitialDirectory = "C:/"
Application.EnableVisualStyles()
If SaveFileDialog1.ShowDialog = DialogResult.OK Then
If SaveFileDialog1.FileName <> "" Then
BackgroundWorker2.RunWorkerAsync()
Dim fs As System.IO.FileStream = CType(SaveFileDialog1.OpenFile(), System.IO.FileStream)
fs.Close()
End If
End If
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
BackGroundWorker do work code:
Private Sub BackgroundWorker2_DoWork(sender As Object, e As DoWorkEventArgs) Handles BackgroundWorker2.DoWork
ExporttoExcel(DataGridView1)
End Sub
Export Data To Excel Code:
Sub ExporttoExcel(ByVal DataGridView1 As DataGridView)
'verfying the datagridview having data or not
If ((DataGridView1.Columns.Count = 0) Or (DataGridView1.Rows.Count = 0)) Then
Exit Sub
End If
'Creating dataset to export
Dim dset As New DataSet
'add table to dataset
dset.Tables.Add()
'add column to that table
For i As Integer = 0 To DataGridView1.ColumnCount - 1
If DataGridView1.Columns(i).Visible = True Then
dset.Tables(0).Columns.Add(DataGridView1.Columns(i).HeaderText)
End If
Next
Dim celltext As String
Dim count As Integer = -1
'add rows to the table
Dim dr1 As DataRow
For i As Integer = 0 To DataGridView1.RowCount - 1
dr1 = dset.Tables(0).NewRow
For j As Integer = 0 To DataGridView1.Columns.Count - 1
If DataGridView1.Columns(j).Visible = True Then
count = count + 1
dr1(count) = DataGridView1.Rows(i).Cells(j).Value
End If
Next
count = -1
dset.Tables(0).Rows.Add(dr1)
Next
Dim excel As New Excel.Application
Dim wBook As Excel.Workbook
Dim wSheet As Excel.Worksheet
wBook = excel.Workbooks.Add()
wSheet = wBook.ActiveSheet()
Dim dt As System.Data.DataTable = dset.Tables(0)
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
'calculate the sum for "المبلغ" from the datagridview
Dim Result As Double
For i As Integer = 0 To DataGridView1.RowCount - 1
Result += DataGridView1.Rows(i).Cells(0).Value
'Change the number 2 to your column index number (The first column has a 0 index column)
'In this example the column index of Price is 2
Next
'add the sum to sheet
wSheet.Cells(DataGridView1.RowCount + 2, 1) = Result
wSheet.Cells(DataGridView1.RowCount + 2, 2) = "المجموع"
' for the header
wSheet.Rows(1).Font.Name = "Droid Arabic Kufi"
wSheet.Rows(1).Font.size = 11
wSheet.Rows(1).Font.Bold = True
wSheet.Rows(1).HorizontalAlignment = Microsoft.Office.Interop.Excel.XlHAlign.xlHAlignCenter
Dim mycol As System.Drawing.Color = System.Drawing.ColorTranslator.FromHtml("#20b2aa")
wSheet.Rows(1).Font.color = mycol
' for all the sheet without header
wSheet.Range("a2", "z1000").Font.Name = "Droid Arabic Kufi"
wSheet.Range("a2", "z1000").Font.Size = 10
' make the sheet Alignment center
wSheet.Range("a2", "z1000").HorizontalAlignment = Microsoft.Office.Interop.Excel.XlHAlign.xlHAlignCenter
wSheet.Range("A1:X1").EntireColumn.AutoFit()
wSheet.Range("A1:X1").EntireRow.AutoFit()
wSheet.Columns("J").ColumnWidth = 28
'make the first column "المبلغ" format is money
wSheet.Columns("A").NumberFormat = "#,##0_);[Red](#,##0)"
' this add Grid line to all rows and columns
Dim formatRange As Excel.Range = wSheet.UsedRange
Dim cell As Excel.Range = wSheet.Range("a1", "j" & DataGridView1.RowCount + 1 & "")
Dim border As Excel.Borders = cell.Borders
border.LineStyle = Microsoft.Office.Interop.Excel.XlLineStyle.xlContinuous
border.Weight = 1.0
' this add header and footer when printing the sheet
wSheet.PageSetup.CenterHeader = "&""Droid Arabic Kufi,Bold""&14الحوالات الصادرة"
wSheet.PageSetup.RightFooter = DateTime.Now
wSheet.PageSetup.LeftFooter = "Page &P of &N"
'make the print page horizontal
wSheet.PageSetup.Orientation = Microsoft.Office.Interop.Excel.XlPageOrientation.xlLandscape
'make all columns fit in one page
wSheet.PageSetup.Zoom = False
wSheet.PageSetup.FitToPagesWide = 1
wSheet.PageSetup.FitToPagesTall = False
Dim strFileName As String = saveFileDialog1.FileName
Dim blnFileOpen As Boolean = False
Try
Dim fileTemp As System.IO.FileStream = System.IO.File.OpenWrite(strFileName)
fileTemp.Close()
Catch ex As Exception
blnFileOpen = False
Exit Sub
End Try
If System.IO.File.Exists(strFileName) Then
System.IO.File.Delete(strFileName)
End If
wBook.SaveAs(strFileName)
excel.Workbooks.Open(strFileName)
excel.Visible = True
Exit Sub
errorhandler:
MsgBox(Err.Description)
End Sub
My answer to your question is really simple with:
xlWorksheet.PageSetup.PrintGridLines = True