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
Related
I was creating an Excel vba to search a keyword in a word document and then return the line above it. Here is the code:
Sub TEST()
Dim s As Word.Selection
fileaddress = "C:\XXXXXX"
Set appWrd = New Word.Application
Set docWrd = appWrd.Documents.Open(fileaddress)
Set aRange = docWrd.Range
Do
aRange.Find.Text = "keyword"
aRange.Find.Execute Forward:=True
If aRange.Find.Found Then
aRange.Select
Set s = Word.Selection
s.MoveUp Unit:=wdLine, COUNT:=1
MsgBox s.Paragraphs(1).Range.ListFormat.ListString
Set s = Nothing
End If
Loop While aRange.Find.Found
docWrd.Close
appWrd.Quit
End Sub
The code works fine the first time, then in the second time a 462 error appears. I guess the issue is probably with this Word.Selection thing. Any idea forks?
PS: The word file is something like below:
Heading style 1
keyword
1.1 Heading style 2
keyword
So the code searches for keyword and then move the cursor one line up from keyword's location and then the msgbox would return "1" and "1.1". However, as I said, the code works fine the first time. I think it is something to do with certain process is not killed in the task manager after the previous run of excel.
SOLVED
New code:
Sub TEST()
Dim s As Word.Selection
fileaddress = "C:\XXXXXX"
Set appWrd = New Word.Application
Set docWrd = appWrd.Documents.Open(fileaddress)
Set aRange = docWrd.Range
Do
aRange.Find.Text = "keyword"
aRange.Find.Execute Forward:=True
If aRange.Find.Found Then
aRange.Select
Set s = appWrd.Selection '<------- This is the only change!
s.MoveUp Unit:=wdLine, COUNT:=1
MsgBox s.Paragraphs(1).Range.ListFormat.ListString
Set s = Nothing
End If
Loop While aRange.Find.Found
docWrd.Close
appWrd.Quit
End Sub
Replace the line
Set s = Word.Selection
with
Set s = appWrd.Selection
The "Word" object does not like to be reused after getting killed (even though it is recreated).
When you mentioned "line above it" I tried checking if the word was in a table or else the sentence. So I compare the words in the document to the keyword then read the row above in the table or the sentence it belongs to, then count backwards until the previous sentence is found.
Sub TEST_Line(fileaddress As String, Keyword As String)
Set appWrd = CreateObject("Word.Application")
Set docWrd = appWrd.Documents.Open(fileaddress)
Set DWords = docWrd.Words
For Counter = 1 To DWords.Count
If UCase(Keyword) Like UCase(DWords.Item(Counter)) Then
If DWords.Item(Counter).Tables.Count > 0 Then
Row_Ref = DWords.Item(Counter).Rows(1).Index - 1
Col_Ref = DWords.Item(Counter).Columns(1).Index
If Row_Ref > 0 Then
MsgBox DWords.Item(Counter).Tables(1).Columns(Col_Ref).Cells(Row_Ref).Range.Text
End If
Else
aRange = DWords.Item(Counter).Sentences(1)
Reverse_Counter = Counter - 1
If Reverse_Counter < 1 Then
'MsgBox "First Sentence"
Else
Do While DWords.Item(Reverse_Counter).Sentences(1) = DWords.Item(Counter).Sentences(1)
Reverse_Counter = Reverse_Counter - 1
Loop
MsgBox DWords.Item(Reverse_Counter).Sentences(1)
End If
End If
End If
Next Counter
docWrd.Close
appWrd.Quit
End Sub
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
I'm building a chart automation script in powerpoint and i have any issue when calling upon "ActivateChartDataWindow".
I would use "Activate" instead of "ActivateChartDataWindow", but "Activate" loads the full Excel program and makes the whole routine run slow and ulgy.
The problem I have is that "ActivateChartDataWindow" does work to populate the charts, but when I manually go to edit the data - right click, edit data - to access the excel application, it does not seem to want to load!
It has been driving my crazy for the last 5 hours and would appreciate any ideas on how to over come this.
OLE.dlll are working correctly and the code I am using is given below.
Code below:
There are 5 slides with one chart on each page and the code below is what i am using as a point of concept
I have a felling i am using "ActivateChartDataWindow" wrong, but there is not much on the web to know what i am doing wrong! Arrrhhhh!
For i = 1 To 5
Set instance = Nothing
Set instance = ActivePresentation.Slides(i).Shapes(1).Chart.ChartData
With instance
.ActivateChartDataWindow
instance.Workbook.Sheets(1).Range("A1:H26").Value = 27
instance.Workbook.Close
End With
Next i
End Sub
As always recommended, you don't need to Activate an object to modify it. If you're trying to handle a Workbook embedded in a slide, you can do it this way
' This function will get you a Workbook object embedded in a Slide (late binding)
Function getEmbeddedWorkbook(sld As Slide) As Object
Dim shp As Shape
On Error Resume Next
For Each shp In sld.Shapes
If shp.Type = 3 Then ' embedded chart workbook created in PP
Set getEmbeddedWorkbook = shp.Chart.ChartData.Workbook
Exit Function
End If
If shp.Type = 7 Then ' embedded workbook pasted from excel
Set getEmbeddedWorkbook = shp.OLEFormat.Object
Exit Function
End If
Next
End Function
' For Testing, I have 6 slides, Some have a workbook pasted from Excel
' OLE, shape type = 7, others have a chart created in PP (type = 3)
Sub Test()
Dim wb As Object, i As Long
For i = 6 To 6 'ActivePresentation.Slides.Count
Set wb = getEmbeddedWorkbook(ActivePresentation.Slides(i))
If Not wb Is Nothing Then
wb.Sheets(1).Range("A1:D5").Value = i * i
End If
Next
End Sub
I have been trying to write a macro that will dynamically fill a textbox on a new sheet will the value of a cell from another sheet.
I have managed to get it working using this:
Sub copyDetail()
' Define variables
Dim pre As Worksheet
Dim des As Worksheet
Set pre = Sheets("Presentation")
Set des = Sheets("Description")
Dim i As Integer
Dim lbl As String
' Scroll through labels and copy where boolean = 1
For i = 2 To 17
If des.Cells(i, 2) = 1 Then
lbl = des.Cells(i, 11)
Sheets("Presentation").Select
ActiveSheet.Shapes.Range(Array("TextBox 1")).Select
Selection.Text = lbl
Else
End If
Next i
End Sub
I basically want to be able to do exactly what this does but without using select all the time as this changes sheets and slows down my code (I have many other sub's to run alongside this one). I've tried things like defining the textbox using this:
Dim myLabel As Object
Set myLabel = pre.Shapes.Range(Array("TextBox 1"))
But then I get an "object doesn't support this property or method" error when I try and call:
myLabel.Text = lbl
You can set the text of a TextBox like so:
ActiveSheet.Shapes("TextBox 1").TextFrame.Characters.Text = "Hello world"
You can set-up a little helper Sub in a Module to make the code re-usable:
Public Sub SetTextBoxText(ws As Worksheet, strShapeName As String, strText As String)
Dim shp As Shape
On Error Resume Next
Set shp = ws.Shapes(strShapeName)
If Not shp Is Nothing Then
shp.TextFrame.Characters.Text = strText
Else
Debug.Print "Shape not found"
End If
End Sub
Using the below code i get a 424 error "Object Required" on the .AddPicure line as indicated. I'm unsure as to why as pic is dimensioned as object, and the .addpicture comand looks fully referenced to me.
Apologies for the length of code, i thought it best to leave in all variables.
I'm using Excel 13 from MS Visio 16, and late binding is necessary.
**Edit: Sorry, it is infact an add text box line thats giving me the problem, I've updated the code below...
Sub testexcel()
Dim pic As Object
Dim rng As Object
Dim tWidth As Long, tHeight As Long
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWb = xlApp.workbooks.Open("C:\Users\tom\Desktop\Book1.xlsx")
Set xlWs = xlWb.sheets("Sheet1")
xlApp.ScreenUpdating = False
Set rng = xlWs.Range("B18")
Set rng2 = xlWs.Range("A1", rng.Offset(-1, -1))
picture1 = "C:\Users\tom\Desktop\PX001.bmp"
pHeight = 145
pWidth = 200
tHeight = 10
tWidth = 200
posX = 10
posY = 10
'On Error GoTo ErrMsg
With xlWs.Range("A1", rng.Offset(-1, -1))
'*******Problem on next line*******
Set txtBx = xlWs.Shapes.AddTextbox(msoTextOrientationHorizontal,
txtPosX, txtPosY, tWidth, tHeight).TextFrame.Characters.Text = "FooBar"
End With
'Some other code here...
End Sub
try splitting it up
Set txtBx = xlWs.Shapes.AddTextbox(msoTextOrientationHorizontal, txtPosX, txtPosY, tWidth, tHeight)
txtBx.TextFrame.Characters.Text = "FooBar"
I think this is what's happening:
xlWs.Shapes.AddTextbox(msoTextOrientationHorizontal, txtPosX, txtPosY, tWidth, tHeight).TextFrame.Characters.Text = "FooBar"
This retunrs false because the second = is interpreted as a comparison. Then you are basically doing Set txtBx = False which causes the error.
It could also be that vba tries to assign the Text property which is a string to txtBx.
edit: I would also suggest using Option Explicit. If VBA knows that txtBx is supposed to be a shape, it tells you it got a type mismatch. In this case you got lucky because the Set tells it to expect an object and thus threw an error. If you wanted to assign a string for example, you would have gotten the error at a later line (or no error at all) because you have False where you expect a string which makes debugging more complicated.