Sources:
Private Sub toEditDataOnReportCell(ByVal passedData As String)
Dim monthlyReportFilePath As String = "./Report/Example.xlsx"
Dim oExcel As Object
Dim oBook As Object
Dim oSheet As Object
'Start a new workbook in Excel
oExcel = CreateObject("Excel.Application")
oBook = oExcel.Workbooks.Open(monthlyReportFilePath)
'Set which worksheet tobe modified
oSheet = oBook.Worksheets(1)
'This will find the lastRow in the sheet
'Dim lastRow As Integer = 7
Dim ETLastRow As Integer = oSheet.usedrange.rows.count
'This is next emptyRow in the sheet
Dim ETemptyRow As Integer = ETLastRow + 1
'edit last empty row val on column 8
Dim columnToMod As Integer = 8
oSheet.Cells(ETemptyRow, columnToMod).value = passedData
ETLastRow = oSheet.usedrange.rows.count
ETemptyRow = ETLastRow + 1
'This will not prompt the user to overwrite the excel sheet
oExcel.DisplayAlerts = False
oBook.Save()
oBook.Close()
oExcel.Quit()
TextBox12.AppendText("Sucess!!!" + vbCrLf + vbCrLf)
End Sub
Giving wrong last row, if in excel doc already have a table with formula in it.
Output Preview:
Targeting In Cell Range (H8:H38)
[1]: https://i.stack.imgur.com/D4RT5.png
But Output In Cell Range (H40:H)
[2]: https://i.stack.imgur.com/0wufs.png
Hehehe, i found the solutions,
Thanks to #StoriKnow & his answer there:
Here is my latest sources:
Private Sub toEditDataOnReportCell(ByVal passedData As String)
Dim monthlyReportFilePath As String = "./Report/Example.xlsx"
Dim oExcel As New Object
Dim oBook As New Object
Dim oSheet As New Object
oExcel = CreateObject("Excel.Application")
oBook = oExcel.Workbooks.Open(monthlyReportFilePath)
oSheet = oBook.Worksheets(1)
Try
Dim sourceCol As Integer, rowCount As Integer, currentRow As Integer
Dim currentRowValue As String
sourceCol = 8 'column H has a value of 8
rowCount = oSheet.Cells(oSheet.Rows.Count, sourceCol).End(Excel.XlDirection.xlUp).Row
'for every row, find the first blank cell and select it
For currentRow = 8 To rowCount
currentRowValue = oSheet.Cells(currentRow, sourceCol).Value
If (currentRowValue Is Nothing) Or (currentRowValue = "") Then
'oSheet.Cells(currentRow, sourceCol).Select
Dim preview As String = currentRow
TextBox12.AppendText(preview + " ")
oSheet.Cells(currentRow, sourceCol).Select
oSheet.Cells(currentRow, sourceCol).value = passedData
Exit Try
End If
Next
Finally
''' DO NOTHING
End Try
''This will not prompt the user to overwrite the excel sheet
oExcel.DisplayAlerts = False
oBook.Save()
oBook.Close()
oExcel.Quit()
end Sub
Output that achived:
Related
I want to sum the same range of values (say B3:B292) in 120 worksheets such that: ΣB3, ΣB4, ΣB5 ...... ΣB292.
I am not getting an error for the below VBA code, but it's also not returning any values.
Sub FAggreg1PNFAWO()
Dim Aggreg1PNFAWO As Workbook
Dim WS_Count As Integer
Dim filePath As String
Dim i As Integer
Dim TotalNp As Variant
filePath = "Directory"
Set Aggreg1PNFAWO = Workbooks.Open(filePath, ReadOnly:=True)
WS_Count = Aggreg1PNFAWO.Worksheets.Count
For i = 1 To WS_Count
'Sheets(i).range("B3:B292") <> "" And
If IsNumeric(Sheets(i).range("B3:B292")) Then
TotalNp = TotalNp + Sheets(i).range("B3:B292")
End If
Next
ActiveWorkbook.Close
ThisWorkbook.Activate
ActiveSheet.range("T4:T293").Value = TotalNp
End Sub
In that case try this:
Sub FAggreg1PNFAWO()
Dim Aggreg1PNFAWO As Workbook, myWB As Workbook
Dim WS_Count As Integer, i As Integer
Dim filePath As String
Dim TotalNp As Variant
Set myWB = ActiveWorkbook
filePath = "Directory"
Set Aggreg1PNFAWO = Workbooks.Open(filePath, ReadOnly:=True)
WS_Count = Aggreg1PNFAWO.Worksheets.Count
For X = 3 To 292
For i = 1 To WS_Count
If IsNumeric(Sheets(i).Range("B" & X)) Then
TotalNp = TotalNp + Sheets(i).Range("B" & X).Value
End If
Next
myWB.Activate
myWB.ActiveSheet.Range("T" & i + 1).Value = TotalNp
TotalNp = 0
Aggreg1PNFAWO.Activate
Next X
End Sub
Here you can use SUM function to do this. In the below answer am assuming B293 cell as empty and using it for summation. If you have some data in that cell then pick some other empty cell then try this.
Sub Sum()
Dim Project1P As Workbook
Dim WS_Count As Integer
Dim i As Integer
Dim V As Variant
Set Project1P = Workbooks.Open("C:\Users\Nandan\Desktop\SO\SO1.xlsx")
WS_Count = Project1P.Worksheets.Count
sumrange (WS_Count)
End Sub
Function sumrange(TotalSheets As Integer)
Dim reserves As Variant
For i = 1 To TotalSheets
Sheets(i).range("B" & 293).Formula = "=SUM(B3:B292)"
Next
For i = 1 To TotalSheets
reserves = reserves + Sheets(i).range("B" & 293)
Next
For i = 1 To TotalSheets
Sheets(i).range("B" & 293).Clear
Next
MsgBox "Total of all sheets :" & reserves
End Function
I need the name of the first empty cell in a column, for example "E15" or "A3"
I've tried using worksheet.Cells.Name and worksheet.Rows.Name but I don't
think that is the correct syntax... please help!
Here's my code
Dim xlApp As Excel.Application
Dim xlWorkBook As Excel.Workbook
Dim xlWorkSheet As Excel.Worksheet
Dim misValue As Object = System.Reflection.Missing.Value
xlApp = New Excel.Application
xlWorkBook = xlApp.Workbooks.Add(eXe)
xlWorkSheet = xlWorkBook.Sheets("sheet1")
Dim eColumn As Excel.Range = xlWorkSheet.Range("E2:E15")
Dim rCell As Excel.Range
For Each rCell In eColumn
If rCell Is Nothing Then
Dim LastCell As String = xlWorkSheet.Rows.Name
MsgBox(LastCell)
End If
MsgBox(rCell.Value)
Next rCell
(update)
I used the following code and got $E$15, is there a way to get the address with out the "$" symbol?
For Each rCell In eColumn
If rCell.Value = "" Then
Dim LastCell As String = rCell.Cells.Address
MsgBox(LastCell)
End If
MsgBox(rCell.Value)
Next rCell
To get the name of the coloumn use:
Dim columnLetter As String = ColumnIndexToColumnLetter(85) ' returns CG
Private Function ColumnIndexToColumnLetter(colIndex As Integer) As String
Dim div As Integer = colIndex
Dim colLetter As String = String.Empty
Dim modnum As Integer = 0
While div > 0
modnum = (div - 1) Mod 26
colLetter = Chr(65 + modnum) & colLetter
div = CInt((div - modnum) \ 26)
End While
Return colLetter
End Function
Thing that you already know how to get the row number you are looking for. Then just use
dim CellName as String = columnLetter & rownum ' the row number you need
This should omit any $ signs you don't want
The example is being taken from here
Regards,
Iakov
I have got some code that looks for a record in an excel file that contains the same characters as a textbox. I then need to delete that row, but I am not sure how to do this. Please could anybody help me?
Here is my code:
Dim oXL As Excel.Application
Dim oSheet As Excel.Worksheet
Dim oRng As Excel.Range
'create object and open workbook
oXL = CreateObject("Excel.application")
oXL.Workbooks.Open(CreateAdmin.FileLocation + "\DVDRental.xls")
'open worksheet
oSheet = oXL.ActiveWorkbook.Sheets("Logins")
oRng = oSheet.Range("A1:A100")
Dim blankspace As Integer = 1
Do Until oRng(blankspace, 2).value() = ""
If oRng(blankspace, 2).value() <> "" Then
blankspace = blankspace + 1
End If
Loop
Dim introw As Integer = 1
Dim user As String
Dim username As String = TextBox1.Text
If username = "" Then
MsgBox("Please Enter A User ID")
Else
Do
user = oRng(introw, 2).value()
If user = username Then
oXL.ActiveWorkbook.Save()
oXL.ActiveWorkbook.Close()
Exit Do
Else : introw = introw + 1
End If
Loop Until introw = blankspace
oRng = Nothing
oSheet = Nothing
oXL.Quit()
oXL = Nothing
TextBox1.Clear()
The following example removes rows with a first column value equal to zero. Modify it to suit your need.
As you can imagine, removing a row "repositions" all the others below, so I found it easier to work upward, rather than track the changes.
For RowDelete = Worksheets(TargetSheet).UsedRange.Rows.Count To 1 Step -1
If Cells(RowDelete, 1).Value = 0 Then
Rows(RowDelete).Delete
End If
Next RowDelete
(If this runs too slowly try ActiveSheet.EnableCalculation = False
and Application.ScreenUpdating = False before, and then again, but True after the loop.)
Goal
Import about 100+ lines of data into a worksheet. Quickly.
Current Problem
The Excel file isn't very large (not even 1MB). Although, we use this Excel file to communicate with SolidEdge which makes it very heavy.
At the moment, it takes about 60 seconds to populate the 100 lines of data. Don't get me wrong, that isn't very long. Whereas I tested it with a new and empty Excel file and it took less than 1 second to populate the data.
Code
Here's my code incase I did something stupid in there:
Private Sub PopulateExcel()
Dim xlApp As Excel.Application = Nothing
Dim xlWorkBooks As Excel.Workbooks = Nothing
Dim xlWorkBook As Excel.Workbook = Nothing
Dim xlWorkSheet As Excel.Worksheet = Nothing
Dim xlWorkSheets As Excel.Sheets = Nothing
Dim Proceed As Boolean = False
Dim RowIndex As Integer = 2
Dim counter As Integer = 0
xlApp = CType(Marshal.GetActiveObject("Excel.Application"), Excel.Application)
xlWorkBooks = xlApp.Workbooks
For Each wb As Excel.Workbook In xlWorkBooks
If wb.Name.Contains("301-AAAA-00X") Then
xlWorkBook = wb
xlWorkSheets = xlWorkBook.Sheets
Exit For
End If
Next
If xlWorkSheets IsNot Nothing Then
For x As Integer = 1 To xlWorkSheets.Count
xlWorkSheet = CType(xlWorkSheets(x), Excel.Worksheet)
If xlWorkSheet.Name = "ImportSheet" Then
Proceed = True
Exit For
End If
Runtime.InteropServices.Marshal.FinalReleaseComObject(xlWorkSheet)
xlWorkSheet = Nothing
Next
End If
If Proceed Then
tspbProgress.Value = 0
tspbProgress.Maximum = dic_Vars.Count
tspbProgress.Visible = True
For Each key As KeyValuePair(Of String, String) In dic_Vars 'Contains all my the data
tsslStatus.Text = "Populating Excel: " & key.Key & " | " & key.Value
xlWorkSheet.Cells(RowIndex, 2).value = key.Key
xlWorkSheet.Cells(RowIndex, 3).value = key.Value
RowIndex += 1
IncProg()
Next
tspbProgress.Visible = False
ReleaseComObject(xlWorkSheets)
ReleaseComObject(xlWorkSheet)
ReleaseComObject(xlWorkBook)
ReleaseComObject(xlWorkBooks)
ReleaseComObject(xlApp)
End If
End Sub
Private Sub ReleaseComObject(ByRef obj As Object)
Try
System.Runtime.InteropServices.Marshal.ReleaseComObject(obj)
obj = Nothing
Catch ex As Exception
obj = Nothing
End Try
End Sub
Conclusion
I was thinking about creating a new Excel file, importing the data there, and just doing a copy / paste to the real Excel file that we use.
Any suggestions?
Good thank you to Byron Wall who helped me find the answer. I now input my data using an array instead of iterating through each cell.
I create my array and populate it depending on how large my dictionary of variables is. I then create a new range using the Resize() method seen below.
Once that's done, everything is populated in an instant!
Dim arrNames(,) As String = New String(AscW(ChrW(dic_Vars.Count)), 1) {}
Dim arrValues(,) As String = New String(AscW(ChrW(dic_Vars.Count)), 1) {}
Dim i As Integer = 0
For Each key As KeyValuePair(Of String, String) In dic_Vars
arrNames(i, 0) = key.Key
arrValues(i, 0) = key.Value
i += 1
Next
If Proceed Then
Dim r As Microsoft.Office.Interop.Excel.Range = xlWorkSheet.Range("B2").Resize(arrNames.GetLength(0))
Dim r2 As Microsoft.Office.Interop.Excel.Range = xlWorkSheet.Range("C2").Resize(arrValues.GetLength(0))
r.Value2 = arrNames
r2.Value2 = arrValues
ReleaseComObject(xlWorkSheets)
ReleaseComObject(xlWorkSheet)
ReleaseComObject(xlWorkBook)
ReleaseComObject(xlWorkBooks)
ReleaseComObject(xlApp)
End If
I am trying to paste few images from one excel to another, but facing an issue in it. the images are overlapping on each other., and even the size is very small.Below is the code of what i have tried.
If Source = ESNAME Then
Dim shp As Microsoft.Office.Interop.Excel.Shape
Dim lCol As Integer = 0
Dim I As Integer = 1
'~~> Loop through all shapes and find the last col of the shape
For Each shp In WS.Shapes
If shp.BottomRightCell.Column > lCol Then _
lCol = shp.BottomRightCell.Column
With WS
'~~> Find actual last Row
Dim LastRow As Integer = I
Dim LastColumn As Integer = I
Dim str As String = "B" & I & "#"
'~~> Check if we have the correct last columnm
If LastColumn < lCol Then LastColumn = lCol
.Range(str.Replace("#", ":") & Split(.Cells(, LastColumn).Address, "$")(1) & LastRow).Copy()
Dim sheet As Microsoft.Office.Interop.Excel.Worksheet
sheet = Nothing
sheet = DW.Worksheets(1)
sheet.Paste()
End With
I = I + 1
Next
End If
Thanks in advance.
Let's say your Workbook1 looks like this
Try this code (TRIED AND TESTED in VS 2010 + OFFICE 2010)
Code
Imports Excel = Microsoft.Office.Interop.Excel
Public Class Form1
Private Sub Button1_Click(sender As System.Object, e As System.EventArgs) Handles Button1.Click
'~~> Define your Excel Objects
Dim xlApp As New Excel.Application
Dim xlWorkBook1 As Excel.Workbook = Nothing
Dim xlWorkBook2 As Excel.Workbook = Nothing
Dim xlWorkSheet1 As Excel.Worksheet = Nothing
Dim xlWorkSheet2 As Excel.Worksheet = Nothing
'~~> Display Excel
xlApp.Visible = True
'~~> Open relevant excel files and set your objects
xlWorkBook1 = xlApp.Workbooks.Open("C:\book1.xlsx")
xlWorkSheet1 = xlWorkBook1.Sheets("Sheet1")
xlWorkBook2 = xlApp.Workbooks.Open("C:\book2.xlsx")
xlWorkSheet2 = xlWorkBook2.Sheets("Sheet2")
Dim xlShp As Excel.Shape = Nothing
Dim xlShape As Excel.Shape = Nothing
For Each xlShp In xlWorkSheet1.Shapes
xlShp.Copy()
xlWorkSheet2.Paste(Destination:=xlWorkSheet2.Range("A1"))
Next
Dim col1 As New Point(10, 10)
Dim col2 As New Point(col1.X * 2 + xlWorkSheet2.Shapes(0).Width, 10)
Dim stdHeight As Integer = CType(xlWorkSheet2.Shapes(0), Excel.Shape).Height + 5
For i As Integer = 0 To xlWorkSheet2.Shapes.Count - 1 Step 2
xlShape = xlWorkSheet2.Shapes(i)
xlShape.Left = col1.X
xlShape.Top = col1.Y + i * stdHeight
xlShape = xlWorkSheet2.Shapes(i + 1)
xlShape.Left = col2.X
xlShape.Top = col2.Y + i * stdHeight
Next
'~~> Save the file
xlWorkBook2.Save()
'~~> Close the File
xlWorkBook1.Close (False)
xlWorkBook2.Close (False)
'~~> Quit the Excel Application
xlApp.Quit()
'~~> Clean Up
releaseObject (xlShp)
releaseObject (xlShape)
releaseObject (xlWorkSheet1)
releaseObject (xlWorkSheet2)
releaseObject (xlWorkBook1)
releaseObject (xlWorkBook2)
releaseObject (xlApp)
End Sub
'~~> Release the objects
Private Sub releaseObject(ByVal obj As Object)
Try
System.Runtime.InteropServices.Marshal.ReleaseComObject (obj)
obj = Nothing
Catch ex As Exception
obj = Nothing
Finally
GC.Collect()
End Try
End Sub
End Class
Workbook 2 Output