I am giving my required Excel Template here. As my present scenario this excel will be stored in a fix path. But CSV will generate everyday.
My vb script should execute everyday to collect data from csv and write into this Excel , but small customization needed.
Here First 3 rows are Fixed Header, I need to convert csv and write values in excel from 4th row. but its obvious we have old data there. so it should delete 4th row to 7th row and put csv value as per required place. With proper border also.
Now tell me is it possible to modify my vbs to get this type of output?
to run the script like below ...
MyScript.vbs : which needs two argument to execute
cscript C:\Test\MyScript.vbs \\C:\Test\Sample.CSV \\C:\Test\Sample.xlsx
Original script is below. but I want to view like below screenshot.
srccsvfile = Wscript.Arguments(0)
tgtxlsfile = Wscript.Arguments(1)
'Create Spreadsheet
'Look for an existing Excel instance.
On Error Resume Next ' Turn on the error handling flag
Set objExcel = GetObject(, "Excel.Application")
'If not found, create a new instance.
If Err.Number = 429 Then '> 0
Set objExcel = CreateObject("Excel.Application")
End If
objExcel.Visible = False
objExcel.DisplayAlerts = False
'Import CSV into Spreadsheet
Set objWorkbook = objExcel.Workbooks.Open(srccsvfile)
Set objWorksheet1 = objWorkbook.Worksheets(1)
'Adjust width of columns
Set objRange = objWorksheet1.UsedRange
objRange.EntireColumn.Autofit()
'This code could be used to AutoFit a select number of columns
'For intColumns = 1 To 17
' objExcel.Columns(intColumns).AutoFit()
'Next
'Make Headings Bold
objExcel.Rows(1).Font.Bold = True
'Freeze header row
With objExcel.ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
objExcel.ActiveWindow.FreezePanes = True
'Add Data Filters to Heading Row
objExcel.Rows(1).AutoFilter
'set header row gray
objExcel.Rows(1).Interior.ColorIndex = 15
'-0.249977111117893
aList=Array("NOT ", "NO ", "NONE", "!")
For each item in aList
For Each c In objWorksheet1.UsedRange
If InStr(1, c.Value, item) > 0 Then
c.Interior.ColorIndex = 6
End If
Next
next
'Save Spreadsheet, 51 = Excel 2007-2010
objWorksheet1.SaveAs tgtxlsfile, 51
'Release Lock on Spreadsheet
objExcel.Quit()
Set objWorksheet1 = Nothing
Set objWorkbook = Nothing
Set objExcel = Nothing
Header and Legend should be Fixed as screenshot.
But there can be alternate way also. If I can get some modified vb script which can create Header like the above screenshot (i.e. merge cell, border, freeze, remove gridlines) and add legend at the bottom, then I don't need to write into existing excel everyday. All-time when vbs executes it should replace old excel (if exist) with this proper format.
record a macro of creating the header and legend. then edit the code for clean up all the .Select ... Selection statements. ... in your code that you posted, you can autofit all the columns with one command by using one of these
ActiveSheet.Columns("A:Q").AutoFit
ActiveSheet.Range(Columns(1), Columns(17)).AutoFit
Related
I am using below VBS code to export one chart (from QlikView) to excel.
Reason I am using Number format = ‘#’ and paste special because if I do not use it then values in the chart like ‘22001E-07’ gets converted to 2.20E-03
sub GPOTest1
set oXL=CreateObject("Excel.Application")
oXL.visible=True
oXL.Workbooks.Add
aSheetObj=Array("CH01")
for i=0 to UBound(aSheetObj)
oXL.Sheets.Add
Set oSH = oXL.ActiveSheet
oSH.Range("A1").Select
Set obj = ActiveDocument.GetSheetObject(aSheetObj(i))
obj.CopyTableToClipboard True
oSH.Columns("B").NumberFormat = "#" ‘In “B” column I get values like 22001E-07
oSH.PasteSpecial -4163
sCaption=obj.GetCaption.Name.v
set obj=Nothing
oSH.Rows("1:1").Select
oXL.Selection.Font.Bold = True
oSH.Cells.Select
oXL.Selection.Columns.AutoFit
oSH.Range("A1").Select
oSH.Name=left(sCaption,30)
set oSH=Nothing
next
set oXL=Nothing
end sub
After running it for the first time, from 2nd time I get message
PasteSpecial method of Worksheet class failed
Referred following link, however, issue persists:
use macro to convert number format to text in Excel
You shouldn't systematically create an Excel instance. Your code leaves Excel open. Once Excel is open, the next time around, you can get a reference to it using GetObject. See the approach taken in the code below, where I've also simplified a couple things:
Sub GPOTest1()
On Error Resume Next
Set oXL = CreateObject("Excel.Application")
If oXL Is Nothing Then
Set oXL = GetObject(Class:="Excel.Application")
End If
On Error GoTo 0
oXL.Visible = True
Set oWB = oXL.Workbooks.Add
aSheetObj = Array("CH01")
For i = 0 To UBound(aSheetObj)
Set oSH = oWB.Sheets.Add
Set obj = ActiveDocument.GetSheetObject(aSheetObj(i))
obj.CopyTableToClipboard True
oSH.Columns("B").NumberFormat = "#" 'In “B” column I get values like 22001E-07
oSH.PasteSpecial -4163
oSH.Rows("1:1").Font.Bold = True
oSH.Columns.AutoFit
oSH.Range("A1").Select
oSH.Name = Left(obj.GetCaption.Name.v, 30)
Set oSH = Nothing
Set obj = Nothing
Next
Set oXL = Nothing
End Sub
I've got a Word document with a section surrounded by hidden text tags < Answers > ...some tables... < /Answers >. A Word macro can return the range of the text between these tags (used to be bookmarks but they had to go).
What I want to do from Excel is open the Word document, get the range between the tags, iterate the tables in that block and retrieve some cells from each row. Those cell data is then written in some rows on a new Excel sheet.
I saw many Word/Excel automation but none that inspired me to retrieve that range between two pieces of text. Best would be to be able to run the Word macro RetrieveRange(strTagName, rngTextBlock) in Word to return the range in rngTextBlock for "Answers" but this seems impossible.
As background: the .docm file is an exam paper with answers and maximum points that I 'd like to transfer into Excel to contain gradings for each student.
Browsing though some more sites, I encountered a C# example that partly did what I needed: rather than using Word's SELECTION stick to ranges to find something. I now can find the text block between the two tags, but still fail on traversing its tables and table rows. No compiler error (and working in Word itself) but I must be missing an external link...
Function CreateSEWorksheet() As Boolean
' Find <ANSWERS> in Word Document, and traverse all tables and write them as rows in worksheet
Dim wdrngStart As Word.Range
Dim wdrngEnd As Word.Range
Dim wdrngAnswers As Word.Range
Dim wdTable As Word.Table
Dim wdRow As Word.Row
Dim strStr As String
Dim bGoOn As Boolean
' Following set elsewhere:
' Set WDApp = GetObject(class:="Application.Word")
' Set WDDoc = WDApp.Documents.Open(filename:="filespec", visible:=True)
Set wdrngStart = WDDoc.Range ' select entire document - will shrink later
Set wdrngEnd = WDDoc.Range
Set wdrngAnswers = WDDoc.Range
' don't use Word SELECT/SELECTION but use ranges instead when finding tags.
If wdrngStart.Find.Execute(findText:="<ANSWERS>", MatchCase:=False) Then
' found!
wdrngAnswers.Start = wdrngStart.End
If wdrngEnd.Find.Execute(findText:="</ANSWERS>", MatchCase:=False) Then
wdrngAnswers.End = wdrngEnd.Start
bGoOn = True
Else
' no closing tag found
bGoOn = False
End If
Else
'no opening tag found
bGoOn = False
End If
If bGoOn Then
For Each wdTable In wdrngAnswers.Tables
' ** below doesn't work anymore: object doesn't support this method **
For Each wdRow In wdTable
' as example, take column 4 of each row
strStr = wdRow.Cells(4).Range.Text
strStr = Left(strStr, Len(strStr) - 2) ' remove end of cell markers
Debug.Print strStr
Next
Next
CreateSEWorksheet = True
Else
CreateSEWorksheet = False
End If
End Function
My intention is to open an existing PowerPoint presentation along with an existing Excel workbook, and subsequently run a VBA macro from Excel which would update the corresponding values in PowerPoint.
For this I've identified the Shape name of the corresponding text boxes I want to update in PowerPoint by highlighting the specific textbox and used Format -> Align. Then I've created 3 columns in Excel with the values:
Slide index Shape name Value
1 Title 2 =CONCATENATE("REPORT ";YEAR(TODAY()))
1 Placeholder for date1 =TODAY()
I use the macro (which I unfortunately can't remember from which site I copied it):
Sub writedata()
Dim c As Object
Dim shapeslide
Dim shapename
Dim shapetext
Set ppapp = GetObject(, "Powerpoint.application")
Set pppres = ppapp.ActivePresentation
For Each c In Blad2.Range("a2:a" & Blad2.Range("a" & Rows.Count).End(xlUp).Row)
shapeslide = Blad2.Range("a" & c.Row)
shapename = Blad2.Range("b" & c.Row)
shapetext = Blad2.Range("c" & c.Row).Text
pppres.Slides(shapeslide).Shapes(shapename).TextEffect.Text = shapetext
Next
End Sub
My problem is that Slide 1 wont be updated at all in its corresponding Shape name. The only action which happens when I execute this macro is that, for some reason, Slide 3 has its font size modified to become size 35 instead of size 16. I can't understand why that is happening. The Shape name of the shape whose font size is altered is neither written into the Excel workbook, nor is it the same shape name as one of those two written in Excel.
Hopefully someone can shed some light into this.
Lets get your slides and shapes listed by excel to ensure that they are what you expect. Sometimes they are really oddly named/IDed. Since you have slides not changing that should and slides changing that should not... we definitely need to doublecheck these. This will itterate through each slide and each shape on that slide and list the slide ID and Name and each shape ID and Name. I have a presentation and the first slide is slide 297 for some reason. Then slide 250 is second. Slide 50 is 3rd. The rest are all numbered oddly also. o.O
Turn on your immediates window to see the debug text.
Sub SlidesShapes()
Dim i As Integer, j As Integer
Set ppapp = GetObject(, "PowerPoint.Application")
Set ppres = ppapp.ActivePresentation
For i = 1 To ppres.Slides.Count'slides and shapes start counting at 1 not 0
Debug.Print ppres.Slides(i).SlideID
Debug.Print ppres.Slides(i).Name
For j = 1 To ppres.Slides(i).Shapes.Count
Debug.Print ppres.Slides(i).Shapes(j).ID
Debug.Print ppres.Slides(i).Shapes(j).Name
Next
Next
End Sub
Also, when you step through your original code (not this snippet) what do you see in your locals window for each step? Anything weird going on there that jumps out at you? Any variables populated with something unexpected or not completely right?
I have some cells with Data Validation. Because the dropdown list is small and hard to read, I have a button which opens a list box and populates it with the cell's Data Validation list.
Dim btnAddToList As OLEObject
Public lboTemp As OLEObject
Set btnAddToList = ws.OLEObjects("btnAddToList")
Set lboTemp = ws.OLEObjects("TempListBoxS")
Set Field = Selection ' This is always cell $D$1, $D$2, or $D$3
btnAddToList.Visible = False
'Create a named range "temp"
ActiveWorkbook.Names.Add Name:="temp", RefersTo:=Field.Validation.Formula1
' open list box
' position list box
' load it with "temp"
With lboTemp
'show the listbox with the list
.Visible = True
.Left = Field.Left
.Top = Field.Top + 50
.ListFillRange = "temp"
.Object.MultiSelect = 0 ' Single select
On Error GoTo errHandler
prev = .LinkedCell
If prev <> "" Then prev = prev & ": " & Range(.LinkedCell).Value ' for debugging
.LinkedCell = Field.Address 'SOMETIMES THIS GIVES Err 440: could not set property value, invalid property value
.Width = Field.Width + 5
.Height = WorksheetFunction.Min(270, .Object.ListCount * 20) 'field.Height + 5
End With
As noted in the comment above, I sometimes, but not always, I get an error when the LinkedCell is supposed to be populated by with the Field.Address.
This code is used by six different cells (D1:D3 on two different worksheets), but the error only appears to occur when one of the D1 cells is the one selected. Those cells have one other thing in common: their data validation lists, respectively, are:
='Category Table'!$F$2:$F$31 and
='Category Table'!$F$32:$F$41
The other four cells -- which don't get the error -- use a complicated dynamic range that references a different table on the "Category Table" sheet. (I don't really think this has anything to do with my problem, but I don't see anything else those cells have in common)
If no one can give me an answer, I'd appreciate some advice on how to track down an intermittent problem.
Thanks!
Maybe the problem is the return of Field.Address. The .Adress property returns, by default, with the absolute value of row and column. You can try Field.Address(RowAabsolute:=false, ColumnAbsolute:=false) . Hope this help.
and sorry my english.
I managed to stop this issue by ensuring that the linked cell was empty before creating the reference.
I am particularly new to coding, not to mention VBA. After a week of really cracking down on learning VBA, I've started to get the hang of it. At the moment, I'm trying to put together a code that will pull the hyperlinks (both addresses and names) out of a word document (eventually word, excel, and power point files), and dump them into the excel file I run the code from. It also dumps the file path and name at the top of the list. I can run the code and pull links from 1 file at a time, and the code pops it out after the end of the last filled line. It will save me endless amounts of time when I have to update links.
Sub ExtractWordLinks()
'the following code gets and sets an open file command bar for word documents
Dim Filter, Caption, SelectedFile As String
Dim Finalrow As String
Filter = "docx Files (*.docx),*.docx, doc Files (*.doc),*.doc, xlsm Files (*.xlsx),*.xlsx"
Caption = "Please Select .doc, .docx, .xlsx files only, " & TheUser
SelectedFile = Application.GetOpenFilename(Filter, , Caption)
'check if value is blank if it is exit
Finalrow = Cells(Rows.Count, 1).End(xlUp).Row
If (Trim(SelectedFile) = "") Then
Exit Sub
Else
'setting up the inital word application object
Set wordapp = CreateObject("word.Application")
'opening the document that is defined in the open file dialog
wordapp.documents.Open (SelectedFile)
'ability to change wether it needs to burn cycles updating the UI
wordapp.Visible = False
'declare excel sheet
Dim xlsSheet As Excel.Worksheet
'set active sheet
Set xlsSheet = Application.ActiveSheet
Dim i As Integer
i = 1
'MsgBox (wordapp.ActiveDocument.Hyperlinks.Count)
For i = 1 To wordapp.ActiveDocument.Hyperlinks.Count
'puts the title of the document in the formatted cells
'xlsSheet.Cells(Finalrow + 1, 1).Value = wordapp.ActiveDocument.Path & "\" & wordapp.ActiveDocument.Name
'formats the file name cell to be a bit easier to discern from the listing.
Range(Cells(Finalrow + 1, 1), Cells(Finalrow + 1, 2)).Font.Bold = True
Range(Cells(Finalrow + 1, 1), Cells(Finalrow + 1, 2)).Merge
'save the links address.
xlsSheet.Cells(Finalrow + i, 1).Value = wordapp.ActiveDocument.Hyperlinks(i).Address
'save the links display text
xlsSheet.Cells(Finalrow + i, 2).Value = wordapp.ActiveDocument.Hyperlinks(i).TextToDisplay
Next
wordapp.ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
wordapp.Quit SaveChanges:=wdDoNotSaveChanges
End If
End Sub
My problem, is that when I run this code on a simple sample file with 3 or so hyperlinks in it across a single page, it returns everything exactly how I want, with the file path/name at the top and all the links in the page directly below it (address in one column, displayed text in the other). However, when I run it on one of the files I am writing this code for (a 95+ page .docx file with ~30 links), it prints out the path/file in the formatted section, and then drops 90 (90 every time) blank lines before printing out the path/file a second time, and then all the links in the document. It does it perfectly, except for the inexplicable second path/file (even there if I comment out the bit I put in) and the 90 blank entries.
Can anyone explain what's going on, or should I try to figure out a way to just bypass the issue by removing my own link code, and including a bit that removes all blank lines?