When I try to write something from the method given by EPPlus i.e. It comes up with two error messages
We have found a problem with some content
Excel completed file level validation and repair. some parts of this workbook may have been repaired or discarded.
Excel opens successfully but, with error messages and one more thing excel I'm writing is already written that means it is a template.
Dim consh As ExcelWorksheet
'Dim excelStream As New MemoryStream()
'excelStream.Write(excel, 0, excel.Length)
Dim exlpck As New ExcelPackage(excel)
If exlpck.Workbook.Worksheets(cellExcelTabName) Is Nothing Then
consh = exlpck.Workbook.Worksheets.Add(cellExcelTabName)
Else
consh = exlpck.Workbook.Worksheets(cellExcelTabName)
End If
Dim start = consh.Dimension.Start
Dim [end] = consh.Dimension.[End]
For row As Integer = 4 To [end].Row
' Row by row...
For col As Integer = 18 To 35
' ... Cell by cell...
' This got me the actual value I needed.
Dim cellValue As String = consh.Cells(row, col).Text
Dim cellAddress = consh.Cells(row, col).Address
Dim i = 0
For Each mText In textToFind
If cellValue.Contains(mText) Then
consh.Cells(cellAddress).Value = cellValue.Replace(mText, "")[enter image description here][1]
consh.Cells(cellAddress).Style.Fill.PatternType = ExcelFillStyle.Solid
consh.Cells(cellAddress).Style.Fill.BackgroundColor.SetColor(color(mText.Substring(1, 1) - 1))
i = i + 1
End If
Next
Next
Next
'Dim exlpck1 As New ExcelPackage(e)
exlpck.Save()
Dim s = New MemoryStream(exlpck.GetAsByteArray())
Return s
As stated here ("I get an error that Excel has found unreadable content ..."), the EPPlus Package does not validate formulas and number formats. You might want to check there for hints.
I found the fix for my code
exlpck.Save()
to be Replaced by
exlpck.SaveAs(ms)
And it worked :)
Related
I have a problem for which I can not find the solution on my own. I tried to read out the values from the following website: https://datawrapper.dwcdn.net/6E03v/580/. I think I have managed to find the corresponding part in the code of the website which is
THIS ONE. As per my understanding the values can be found with tag "span" or class "fg", but none of them seems to work. This is the code I am using for it in the version I use tag "span":
Dim WertFG As Selenium.WebElement
Dim WerteFG As Selenium.WebElements
Dim strTargetTab As String
Dim lgNaechsteFreieZeileZwiSpTblFaelleNachAlter As Long
Dim lgSpalte As Long
Dim lgNaechsteFreieZeileReiterNTVCoronadaten As Long
'Wertzuweisung Variablen
Set ChromeBrowser = New Selenium.ChromeDriver
'Chrome starten und auf die relevante Seite für die gesuchte TabelleCoronaVirusPandemieParameter gehen
ChromeBrowser.Start baseUrl:="https://datawrapper.dwcdn.net/"
ChromeBrowser.Get "/6E03v/577/"
'Werte auslesen
strTargetTab = ThisWorkbook.Worksheets("ZwiSp Tbl Fälle nach Alter").Name
ThisWorkbook.Worksheets(strTargetTab).Activate
ThisWorkbook.Worksheets(strTargetTab).Range("A1:A50").ClearContents
Application.Wait (Now + TimeValue("00:00:03"))
'Tabellenwerte auslesen
Set WerteFG = ChromeBrowser.FindElementsByTag("span")
lgNaechsteFreieZeileZwiSpTblFaelleNachAlter = ThisWorkbook.Worksheets(strTargetTab).Cells(Rows.Count, 1).End(xlUp).Row + 1
lgSpalte = 1
For Each WertFG In WerteFG
ThisWorkbook.Worksheets(strTargetTab).Cells(lgNaechsteFreieZeileZwiSpTblFaelleNachAlter, lgSpalte).Value = WertFG.Text
lgNaechsteFreieZeileZwiSpTblFaelleNachAlter = lgNaechsteFreieZeileZwiSpTblFaelleNachAlter + 1
Next WertFG
ChromeBrowser.Close
Does someone have an idea, why this does not work? Has it something to do with the fact, that the values on the graph are only shown when you hover above the corresponding part of the graph?
Thanks for your help!
Oliver
Addition:
What I want to do:
Read out all the values for tag “span” to a worksheet in excel. Each value should be written in consecutive cell in the worksheet, i.e. A2, A3, ….
What the macro does:
Reads out the values for tag “span” for the first 4 rows then delivers 11 rows with no values and then again shows the remaining values of the website for the element “span”. I assume that in the 11 empty rows the numbers to the graph (this is what I need) would be shown, if the macro would work correctly. I have also attached a screenshot of the read out results to this post:
Read Out Results Excel Worksheet
There is a wait needed before download is pulling from that page.
Also, it would be better to target specific spans e.g.
Dim values As webelements, labels As webelements, r As Long
Set values = chromebrowser.FindElementsByCss(".dontshow span")
Set labels = chromebrowser.FindElementsByCss(".series span")
r = 0
For i = 1 To labels.Count Step 2
Debug.Print labels.Item(i).Text
Debug.Print values(i).Text
Debug.Print values(i + 1).Text
r = r + 1
Next
However, data comes from a csv that you can download. The csv has a timestamp parameter which may help with caching. I doubt server does much with it. #TimWilliams wrote a very nice little function to generate unix timestamps which you can use to construct the csv download url.
So, if there is other stuff you want on that page you can just chromebrowser.get to the constructed url and it will download:
Public Sub GetCovidNumbers()
Dim downloadUrl As String
downloadUrl = "https://static.dwcdn.net/data/6E03v.csv?v=" & CStr(toUnix(Now))
Debug.Print downloadUrl
'd.get downloadUrl
End Sub
Public Function toUnix(dt) As Long
'https://stackoverflow.com/a/12326121 #TimWilliams
toUnix = DateDiff("s", "1/1/1970", dt)
End Function
Or, if you only need that, you can set a download path and use urlmon to download from constructed url e.g.
Public Const folderName As String = "C:\Users\<user>\Desktop\covid.csv" '<=Change as required
Public Sub downloadCSV()
Dim ret As Long
ret = URLDownloadToFile(0, "https://static.dwcdn.net/data/6E03v.csv?v=" & CStr(toUnix(Now)), folderName, BINDF_GETNEWESTVERSION, 0)
End Sub
In all cases, you need to tidy up the headers in output and the age category 5-9. I would simply ignore those as they are constants so you can have them stored elsewhere.
I have created some code to populate combo boxes on my form from a excel file when the form loads.
As part of the code, it is supposed to release the objects associated but it does not
Dim excel As New Excel.Application
Dim w As Excel.Workbook = excel.Workbooks.Open("C:\Email Template\Violations Log\Violations Log.xlsx")
Dim sheet As Excel.Worksheet = w.Worksheets("Individual Data")
Dim r As Excel.Range = sheet.Range("A2:A300")
Dim array(,) As Object = r.Value(excel.XlRangeValueDataType.xlRangeValueDefault)
Dim sheet2 As Excel.Worksheet = w.Worksheets("Category")
Dim s As Excel.Range = sheet2.Range("A2:A20")
Dim array2(,) As Object = s.Value(excel.XlRangeValueDataType.xlRangeValueDefault)
Dim bound0 As Integer = array.GetUpperBound(0)
Dim bound1 As Integer = array.GetUpperBound(1)
Dim j As Integer
Dim x As Integer
Dim s1 As String
If array IsNot Nothing Then
' Loop over all elements.
For j = 1 To bound0
For x = 1 To bound1
s1 = array(j, x)
If s1 IsNot Nothing Then
If Not ComboBox1.Items.Contains(s1.ToString) Then
ComboBox1.Items.Add(s1.ToString)
End If
End If
Next
Next
End If
If array IsNot Nothing Then
' Loop over all elements.
For j = 1 To bound0
For x = 1 To bound1
s1 = array2(j, x)
If s1 IsNot Nothing Then
If Not ComboBox2.Items.Contains(s1.ToString) Then
ComboBox2.Items.Add(s1.ToString)
End If
End If
Next
Next
End If
w.Close(False)
excel.Quit()
ReleaseObject(excel.XlRangeValueDataType.xlRangeValueDefault)
ReleaseObject(excel)
ReleaseObject(array)
ReleaseObject(array2)
ReleaseObject(r)
ReleaseObject(s)
ReleaseObject(sheet)
ReleaseObject(sheet2)
ReleaseObject(w)
ReleaseObject(bound0)
ReleaseObject(bound1)
ReleaseObject(j)
ReleaseObject(x)
ReleaseObject(s1)
Ive tried to release every object that is referenced but it still has a connection to the excel document.
Have I missed an object? or something bigger?
I have another code that copies from the form to that same excel document and that does not leave any processes open. (I have to kill the excel process that is created from loading the form to be able to use the code to copy data)
Any help would be greatly appreciated.
Figured it out.
The code would stop running and not complete the release object section of the code.
Using debugging I found that I was getting an error message which was muted. I resolved the error message and now it runs fine.
Thanks for trying to help.
I have an automation script running whose output is various document types and printing those documents with various printer settings. I am printing to the same printer for all documents, so that's nice. I have three excel worksheets that need to be printed. These I am printing using the built-in "PrintOutEx" method. One onto a letter size paper and two to 11x17. Next, I have the script print a word document, which I am printing using the built-in "PrintOut" method. This is to be printed on an 11x17 paper but scaled so that two pages print side by side. Lastly, I have to print a multi-page tiff document which I am printing using a print handler. I am having a number of issues with this and I apologize if these are silly question and appreciate any help I can gather.
I am trying to keep the default printer the same as when I start the subroutines and that doesn't seem to be working using the PrinterSettings methods.
About the default printer: the default printer changes to the printer I want (doesn't change back at the end). The default printer is set to 11x17. If I change the default settings of the printer to 8.5x11 everything prints to 8.5x11.
The script seems to be ignoring the settings/pagesettings/setups that I am providing it with.
The word document print is not scaled to fit the paper and I have tried setting the paper size to 11x17 as well as 8.5x11 and scaling the print but that just looks really bad.
The first excel worksheet does not print to a letter size paper.
The second and third worksheets work okay (as long as the default printer settings are as desired; see point 2).
The multipage tiff document prints okay as long as the default printer's default settings are correct.
I am not a professional programmer so I apologize if the question has a simple answer or the code looks horrifying. I researched tons on this question and couldn't find a solution that worked. :( I stepped through the code line by line and there are no errors. I am attaching the code I have thus far.
Thanks!!!
Public Sub PrintSPIDPackage(SPID As String)
On Error GoTo errHandler
Dim printerSettings As New Printing.PrinterSettings
Dim curPrinter As String
Dim engPrinter As String
Dim purPrinter As String
engPrinter = "engBLAH"
purPrinter = "purBLAH"
curPrinter = printerSettings.PrinterName
Dim spidBBPath As String
spidBBPath = ****REDACTED
spidDrawingPackagePath = ***REDACTED***
Dim eAPP As New Excel.Application
Dim wB As Excel.Workbook
Dim wS As Excel.Worksheet
Dim rng As Excel.Range
Dim lRow As Integer
Dim wAPP As New Word.Application
Dim doc As Word.Document
wB = eAPP.Workbooks.Open(spidBBPath)
wS = wB.Worksheets(selectedSheet & " OPs")
wS.PageSetup.PaperSize = Excel.XlPaperSize.xlPaperLetter 'I would think this causes the printer to printout to a letter size paper
wS.PrintOutEx(ActivePrinter:=engPrinter)
wS = wB.Worksheets(selectedSheet)
lRow = wS.Range("A" & wS.Rows.Count).End(Excel.XlDirection.xlUp).Row + 3
rng = wS.Range("A1:I" & lRow)
rng.PrintOutEx(ActivePrinter:=engPrinter) 'PRINT SHOULD BE AN 11x17
wS = wB.Worksheets(selectedSheet & " MLB")
wS.PrintOutEx(ActivePrinter:=engPrinter) 'PRINT SHOULD BE AN 11x17
wB.Close(False)
eAPP.Quit()
Runtime.InteropServices.Marshal.ReleaseComObject(wS)
Runtime.InteropServices.Marshal.ReleaseComObject(wB)
Runtime.InteropServices.Marshal.ReleaseComObject(eAPP)
If InStr(xPath, ".doc") <> 0 Then
doc = wAPP.Documents.Open(xPath)
wAPP.ActivePrinter = engPrinter
doc.PageSetup.PaperSize = Word.WdPaperSize.wdPaperLetter ''''''print out should be 11x17 with two pages side by side
wAPP.PrintOut(PrintZoomColumn:=2, PrintZoomRow:=1) ', PrintZoomPaperHeight:=2 * (11 * 1440), PrintZoomPaperWidth:=2 * (8.5 * 1440)) '''''AS you see I tried scaling...
doc.Close(False)
doc = Nothing
wAPP.Quit()
wAPP = Nothing
End If
Dim pDoc As New Printing.PrintDocument
currPage = 0
AddHandler pDoc.PrintPage, AddressOf pDocPage
PrintDialog1.Document = pDoc
pDoc.DefaultPageSettings.Landscape = True
pDoc.DocumentName = SPID & "-Drawing Package"
pDoc.PrinterSettings.PrinterName = engPrinter
pDoc.DefaultPageSettings.Landscape = True
pDoc.DefaultPageSettings.Margins.Left = 50
pDoc.DefaultPageSettings.Margins.Right = 50
pDoc.DefaultPageSettings.Margins.Top = 50
pDoc.DefaultPageSettings.Margins.Bottom = 50
Dim ps As New Printing.PaperSize("Tabloid", 1700, 1100)
ps.PaperName = Printing.PaperKind.Tabloid
pDoc.DefaultPageSettings.PaperSize = ps
pDoc.Print()
printerSettings.PrinterName = curPrinter 'this should reset the user's default printer to the original setting to before when this routine started??
Exit Sub
errHandler:
MsgBox(Err.Description)
End Sub
Sub pDocPage(ByVal sender As Object, ByVal e As Printing.PrintPageEventArgs)
Dim img As Image = Image.FromFile(spidDrawingPackagePath)
Dim pCount = img.GetFrameCount(FrameDimension.Page)
img.SelectActiveFrame(FrameDimension.Page, currPage)
Using stReader As IO.MemoryStream = New IO.MemoryStream
img.Save(stReader, ImageFormat.Bmp)
Dim bmp As Bitmap = CType(Image.FromStream(stReader), Bitmap)
e.Graphics.DrawImage(bmp, 0, 0)
bmp.Dispose()
End Using
currPage += 1
If currPage < pCount Then
e.HasMorePages = True
End If
End Sub
Im intending to conduct a VBA macro which returns the cell value of C34 of the file referenced by path which has the sheet names as presented in myHeadings.
Sub Test()
Dim myHeadings() As String
Dim i As Long
Dim path As String
path = "C:\pathtofile\file.xlsx"
Dim currentWb As Workbook
Set currentWb = ActiveWorkbook
Dim openWb As Workbook
Set openWb = Workbooks.Open(path)
Dim openWs As Worksheet
myHeadings = Split("Januari,Februari,Mars", ",")
For i = 0 To UBound(myHeadings)
Set openWs = openWb.Sheets(myHeadings(i))
currentWb.Sheets("Indata").Range("AA" & 73+Application.Match (myHeadings(i),Array,False)).Value = openWs.Range("C34").Value
Next i
End Sub
This however gives the error message: Automation Error -2147221080 (800401a8) at the code snippet:
currentWb.Sheets("Indata").Range("AA73+Application.Match (i,Array,False)").Value = openWs.Range("C34").Value
I'm new to VBA and am yet to create a macro actually runable, so the cause may be trivial. From googling I'm yet to find a solution to this specific problematic.
EDITED some code to remove "Array" and updated t
I think you want this:
currentWb.Sheets("Indata").Range("AA" & 73 + Application.Match(i,Array,False)) = openWs.Range("C34")
If the result of
Application.Match(i,Array,False)
is equal to 1, you want to make AA74 to equal whatever is in openws.Range("C34"), right?
'&' is a concatentation character, so what we are saying above is that we take "AA" then calculate 73 + 1 and concatenate it to the end. The bit you were missing is escaping the text after the "AA" to do the numerical calculation.
EDIT:-
After reading Aiken's comments above, I believe your answer should be to remove the Match function entirely:
currentWb.Sheets("Indata").Range("AA" & 73 + i + 1).Value = openWs.Range("C34").Value
I need to harvest and colate data from an oOcalc workbook.
Part of the information is presented as comments on the cell.
I cant figure out a formula to do it and Im not familiar with oOcalc DOM's to manipulate the item.
Hope someone can help me out.
Thanks.
Just had to figure this one out myself, so here is a macro that will copy the comments of cells in one sheet to actual cells in another sheet.
It could be better, but it gets the job done, so its not worth putting anymore (of my) time into!
REM ****** BASIC *********
Sub ExtractCommentAnnotationThings
Dim myDoc as Object
Dim originalSheet as Object
Dim newSheet as Object
Dim originalCell as Object
Dim newCell as Object
Dim commentString As String
REM DEFINE VAR FOR OUR LOOP
Dim iTargetRow, iTargetColumn As Long
Const kEndRow = 950
Const kEndColumn = 20
REM SET DOC
myDoc = ThisComponent
REM GET SHEET
originalSheet = myDoc.Sheets(0)
newSheet = myDoc.Sheets(1)
REM START LOOP
For iTargetRow = 0 To kEndRow: DoEvents
For iTargetColumn = 0 To kEndColumn: DoEvents
originalCell = originalSheet.getCellByPosition(iTargetColumn,iTargetRow)
REM commentString = Trim(originalCell.Comment.Text)
If originalCell.Annotation.isVisible = True Then
commentString = originalCell.getAnnotation().String
newCell = newSheet.getCellByPosition(iTargetColumn,iTargetRow)
newCell.String = commentString
End If
Next
Next
REM CONTINUE LOOP
End Sub
Set the kEndRow and kEndColumn to include only the range of cells you want copied.
Set the originalSheet and newSheetappropriately as well (might need to create a new sheet first), so they're copied where you want them to be.
Hope it helps!