I'm trying to copy certain calculated values from MS excel to notepad. But its fetching empty values. can someone please check and help me resolve this issue?
Private Sub Button2_Click(sender As Object, e As EventArgs) Handles Button2.Click
workbook = xls.Workbooks.Open(filereader & "excelfilename.xls")
worksheet = workbook.Worksheets(1)
Dim Datawriter As New StreamWriter(filereader & "FiletoCopy.txt")
Dim range1 As Excel.Range
Dim range2 As Excel.Range
Dim range3 As Excel.Range
Dim range4 As Excel.Range
Dim range5 As Excel.Range
Dim CellValue1 As String
Dim CellValue2 As String
Dim CellValue3 As String
Dim CellValue4 As String
Dim CellValue5 As String
range1 = CType(worksheet, Excel.Worksheet).Range(“A1”)
range2 = CType(worksheet, Excel.Worksheet).Range(“A2”)
range3 = CType(worksheet, Excel.Worksheet).Range(“A3”)
range4 = CType(worksheet, Excel.Worksheet).Range(“A4”)
range5 = CType(worksheet, Excel.Worksheet).Range(“A5”)
CellValue1 = Math.Round((range1.Value), 2)
CellValue2 = Math.Round((range2.Value), 2)
CellValue3 = Math.Round((range3.Value), 2)
CellValue4 = Math.Round((range4.Value), 2)
CellValue5 = Math.Round((range5.Value), 2)
Datawriter.WriteLine(CellValue1, vbCrLf)
Datawriter.WriteLine(CellValue2, vbCrLf)
Datawriter.WriteLine(CellValue3, vbCrLf)
Datawriter.WriteLine(CellValue4, vbCrLf)
Datawriter.WriteLine(CellValue5, vbCrLf)
Datawriter.Close()
MessageBox.Show("Output Generated Sucessfully", "Success", MessageBoxButtons.OK)
End Sub
I changed the names of your worksheet and workbook. I just don't like variables named the same as the class name.
I used Path.Combine so I don't have to worry about whether the backslash is there or not.
I created and filled a list of doubles containing the values from you spreadsheet.
I am using a string builder to build the text to be saved. A StringBuilder is mutable (changeable) unlike a String. Each string would have to be discarded and a new one created otherwise.
I used the File class in System.IO to create and write the file.
Private Sub Button2_Click(sender As Object, e As EventArgs) Handles Button2.Click
Dim filereader = "C:\SomeFolder\"
Dim wbook = xls.Workbooks.Open(Path.Combine(filereader, "excelfilename.xls"))
Dim wsheet As Excel.Worksheet = CType(wbook.Worksheets(1), Excel.Worksheet)
Dim lstDoubles As New List(Of Double) From {
CDbl(wsheet.Range("A1").Value),
CDbl(wsheet.Range("A2").Value),
CDbl(wsheet.Range("A3").Value),
CDbl(wsheet.Range("A4").Value),
CDbl(wsheet.Range("A5").Value)
}
'StringBuilder requires Imports System.Text
Dim sb As New StringBuilder
For Each d In lstDoubles
Dim roundedString = Math.Round(d, 2).ToString
sb.AppendLine(roundedString)
Next
File.WriteAllText(Path.Combine(filereader, "FiletoCopy.txt"), sb.ToString)
MessageBox.Show("Output Generated Sucessfully", "Success", MessageBoxButtons.OK)
End Sub
You can also try the following methods. I just slightly modified some of your code.
Imports System.IO
Imports Microsoft.Office.Interop.Excel
Public Class Form1
Dim filereader As String = "E:\Julie\Case\AccessDB\"
Dim xls As Application = New Application()
Dim Workbook As Workbook
Dim Worksheet As Worksheet
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
Workbook = xls.Workbooks.Open(filereader & "exceltest.xlsx")
Worksheet = Workbook.Worksheets(1)
Dim Datawriter As New StreamWriter(filereader & "FiletoCopy.txt")
For i = 1 To 5
Dim temp As String = (CType(Worksheet.Cells(1, i), Range)).Text
Datawriter.WriteLine(temp, vbCrLf)
Next
Datawriter.Close()
MessageBox.Show("Output Generated Sucessfully", "Success", MessageBoxButtons.OK)
End Sub
End Class
Related
*Resolved. There was a hidden active build in the background.
I'm attempting to pull data from an existing excel sheet into the VB program as an array, however I've run into an error at the build stage. I'm quite new to VB and inexperienced in this use.
The existing code is as follows:
Dim objApp As Excel.Application
Dim objBook As Excel._Workbook
Private Sub Button2_Click(ByVal sender As System.Object,
ByVal e As System.EventArgs) Handles Button2.Click
Dim objSheets As Excel.Sheets
Dim objSheet As Excel._Worksheet
Dim range As Excel.Range
'Get a reference to the first sheet of the workbook.
On Error GoTo ExcelNotRunning
objApp = CreateObject("Excel.Application")
objBook = objApp.Workbooks.Open(Filename:="C:\Users\KZM4FR\Documents\Ecosystem_Workbook_Full_Data_data.csv", ReadOnly:=True)
objSheets = objBook.Worksheets
objSheet = objSheets(1)
ExcelNotRunning:
If (Not (Err.Number = 0)) Then
MessageBox.Show("Missing Workbook?")
'We cannot automate Excel if we cannot find the data we created,
'so leave the subroutine.
Exit Sub
End If
'Get a range of data.
range = objSheet.Range("A1", "E5")
'Retrieve the data from the range.
Dim saRet(,) As Object
saRet = range.Value
'Determine the dimensions of the array.
Dim iRows As Long
Dim iCols As Long
iRows = saRet.GetUpperBound(0)
iCols = saRet.GetUpperBound(1)
'Build a string that contains the data of the array for testing.
Dim valueString As String
valueString = "Array Data" + vbCrLf
Dim rowCounter As Long
Dim colCounter As Long
For rowCounter = 1 To iRows
For colCounter = 1 To iCols
'Write the next value into the string.
valueString = String.Concat(valueString,
saRet(rowCounter, colCounter).ToString() + ", ")
Next colCounter
'Write in a new line.
valueString = String.Concat(valueString, vbCrLf)
Next rowCounter
'Report the value of the array.
MessageBox.Show(valueString, "Array Values")
End Sub
Image of the build message
I wrote a program in VB.net in visual studio and wanted to test if it still works, after installing windows 11
now I have the problem it always stops at the line Dim ws As Worksheet = wk2.Sheets(1) Does anyone know the problem?
Imports Microsoft.Office.Interop.Excel
Class MainWindow
Private Sub Button_Click(sender As Object, e As RoutedEventArgs)
Dim MyExcel As New Microsoft.Office.Interop.Excel.Application
MyExcel.Visible = True
Dim wk1, wk2 As Workbook
Dim path1, path2, path3 As String
path1
path2
path3
wk1 = MyExcel.Workbooks.Open(path1)
wk2 = MyExcel.Workbooks.Open(path2)
' Dim ws1 = wk1.Sheets(1)
'ws1.Range("F:F").Replace(("_*"), "")
wk1.Unprotect()
wk2.Unprotect()
Dim Row1 = wk1.Sheets(1).Cells(wk1.Sheets(1).Rows.Count, 1).End(-4162).Row
Dim Row2 = wk2.Sheets(1).Cells(wk2.Sheets(1).Rows.Count, 1).End(-4162).Row + 1
Dim Rng1 = MyExcel.Intersect(wk1.Sheets(1).UsedRange, wk1.Sheets(1).Range("2:" & Row1))
Dim Rng2 = wk2.Sheets(1).Range("A" & Row2).ReSize(Rng1.Rows.Count, Rng1.Columns.Count)
Rng2.Value = Rng1.Value
wk1.Close(SaveChanges:=False)
wk2.SaveAs(path3)
wk2.Close()
Dim ws As Worksheet = wk2.Sheets(1)
Dim StartDatum As String
Dim EndDatum As String
StartDatum = InputBox("Start-Datum:", "Eingabe", Format(Now, "YYYYMMDD"))
EndDatum = InputBox("End-Datum:", "Eingabe", Format(Now, "YYYYMMDD"))
ws.Range("D:D").Replace(("Startdatum im Format JJJJMMTT"), StartDatum)
ws.Range("E:E").Replace(("Enddatum im Format JJJJMMTT"), EndDatum)
ws.Range("A:AZ").Replace(("Keine Eintragung..."), "")
ws.Range("A:AZ").Replace(("Keine Ei"), "")
ws.Range("F:F").Replace(("_*"), "")
ws.Range("F:F").Replace(("-*"), "") ' Bei Änderung nochmal hier löschen und mit dem oberen auskommentierten ersetzen.
ws.Range("A:AZ").Replace(("Keine OP"), "")
ws.SaveAs()
End Sub
End Class
I tried it before and it worked. Now it doesn't work anymore.
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.
Hi How can I access a spreadsheet from AutoCad and take a value from there and use it on AutoCAd
Here is my code but it does not get the value , it's always empty. Don't know what's wrong
Sub move()
Dim EXCELApplication As Object
Dim ExcelWorksheet As Object
Set EXCELApplication = CreateObject("Excel.Application")
EXCELApplication.workbooks.Open AcadToExcel
EXCELApplication.Visible = True
Set ExcelWorksheet = EXCELApplication.ActiveWorkbook.Sheets("Sheet1")
modelsize = ExcelWorksheet.Cells(21, 3).Value
Size = modelsize
End Sub
I just tested this and it works just fine for me:
Public Sub GetFromExcel()
Dim sFile As String
sFile = "C:\Users\" & Environ$("Username") & "\Desktop\Test2.xlsx"
Dim EXCELApplication As Object
Dim ExcelWorksheet As Object
Dim sValue As String
Set EXCELApplication = CreateObject("Excel.Application")
EXCELApplication.workbooks.Add sFile
EXCELApplication.Visible = True
Set ExcelWorksheet = EXCELApplication.ActiveWorkbook.Sheets("Sheet1")
sValue = ExcelWorksheet.Range("A1").Value
MsgBox sValue
End Sub
If it doesnt work for you, then the problem is your filename.
asked a question on stackoverflow a while ago that dealt with creating shapes in PPT based on data input by the user. After gradually expanding my code i am now able to create shapes based on excel data in PPT. (At the same time my questions are now too far from the original question)
However, since i worked with a fixed number of variables given the case that i would like to create a varying number of shapes based on the excel data, i would have to change the code everytime i want to create e.g. more shapes than the code originally was designed for.
So what i did was try this code
Private Sub ToggleButton1_Click()
Dim w1 As Integer
Dim w2 As Integer
Dim w3 As Integer
Dim FileStr As String
Dim TabStr As String
Dim Cell As String
Dim XLApp As New Excel.Application
Dim ObjXL As Excel.Workbook
Dim Value As Integer
Dim Value2 As Integer
Dim Value3 As Integer
Dim i As Integer
Dim zahl As Integer
FileStr = "C:\Users\mjschmitt\Documents\VBATest\Test.xlsx"
Set ObjXL = XLApp.Workbooks.Open(FileStr)
i = ObjXL.Worksheets("Tabelle1").Cells(Rows.Count, "A").End(xlUp).Row
ObjXL.Worksheets("Tabelle1").Range("B1").Value = i
For zahl = 1 To i
Do
Value = ObjXL.Worksheets("Tabelle1").Cell(zahl, "A").Value
w1 = Value
Set myDocument = ActivePresentation.Slides(35)
myDocument.Shapes.AddShape Type:=msoShapeRectangle, _
Left:=50, Top:=50, Width:=w1, Height:=200
Loop Until zahl = i
Next
End Sub
But i get "Runtime error 438, Object doesn't support this property or method".
The debugger does not even point me to the wrong line so i am pretty lost at this point. How could i properly implement this loop?`
Thanks!
(Code that worked
Private Sub ToggleButton1_Click()
Dim w1 As Integer
Dim w2 As Integer
Dim w3 As Integer
Dim FileStr As String
Dim TabStr As String
Dim Cell As String
Dim XLApp As New Excel.Application
Dim ObjXL As Excel.Workbook
Dim Value As Integer
Dim Value2 As Integer
Dim Value3 As Integer
FileStr = "C:\Users\username\Documents\VBATest\Test.xlsx"
Set ObjXL = XLApp.Workbooks.Open(FileStr)
Value = ObjXL.Worksheets("Tabelle1").Range("A1").Value
Value2 = ObjXL.Worksheets("Tabelle1").Range("B1").Value
Value3 = ObjXL.Worksheets("Tabelle1").Range("C1").Value
w1 = Value
w2 = Value2
w3 = Value3
Set myDocument = ActivePresentation.Slides(35)
myDocument.Shapes.AddShape Type:=msoShapeRectangle, _
Left:=50, Top:=50, Width:=w1, Height:=200
myDocument.Shapes.AddShape Type:=msoShapeRectangle, _
Left:=50, Top:=50, Width:=w2, Height:=200
myDocument.Shapes.AddShape Type:=msoShapeRectangle, _
Left:=50, Top:=50, Width:=w3, Height:=200
End Sub