I cannot get an original copy of word to open. It only allows me a read only copy. The Doc.Tables.Add... does not seem to work.
I will eventually pass an array to this sub routine, containing data to write to the fields of #the table. First I have to get it to add tables. I get the #sense that my "Doc" is not recognized. Any help is appreciated.
Sub InsertTbl()
Dim wd As Word.Application
Dim Doc As Word.Document
Dim fn As String
fn = "H:\JailData\aaNEW\GTL_Receipts.docx"
Set wd = New Word.Application
wd.Visible = True
Set Doc = wd.Documents.Open(fn)
MsgBox Doc.Tables.Count
Doc.Tables.Add Range:=Selection.Range, NumRows:=3, NumColumns:=4
tblIndx = Doc.Tables.Count
With Doc.Tables(tblIndx).Application
.Left = 100
.Top = 200
End With
Doc.Tables(tblIndx).Range.Font.Size = 8
End Sub
Related
I am trying to write a function which will delete all sheets except the one passed as parameter. Below function is being called but function does not delete any sheets. How can I delete all worksheets except one?
........
Set ExcelObj = createobject("excel.application")
ExcelObj.Visible = true
Set ConfigFile = ExcelObj.Workbooks.Open (FilePath)
Set ConfigSheet = ConfigFile.Worksheets("Scripts")
Set ConfigApplicationSheet = ConfigFile.Worksheets("Applications")
Set ExecutiveSummarySheet = ConfigFile.Worksheets("Summary")
ExcelObj.ActiveWorkBook.SaveAs SummaryFilePath
DeleteSheet "ConfigScripSheet","Summary"
Function DeleteSheet(ConfigSheet,mySheetname)
'Writing Name and Path of each File to Output File
For Each ObjFile In ObjFiles
ObjOutFile.WriteLine(ObjFile.Name & String(50 - Len(ObjFile.Name), " ") & ObjFile.Path)
Next
ObjOutFile.Close
DeleteSheet = 0
ExcelObj.DisplayAlerts = False
For Each objWorksheet In ConfigSheet.Worksheets
If not objWorksheet.Name = mySheetname Then
DeleteSheet = 1
ConfigScripSheet.sheets(objWorksheet.Name).Select
ConfigScripSheet.sheets(objWorksheet.Name).Delete
ExcelObj.DisplayAlerts = False
End If
Next
End Function
Trying to correct your code above was too much of a minefield for me as I couldn't tell what you meant in several places - so I rewrote it based on what you had said in the description was your goal.
The code below will open the file, associate the objects the way you had them, pass the workbook object and a sheet name not to be deleted into the DeleteSheet function, which will delete any sheet in the workbook that is not named as per the passed in parameter SheetNameNotToDelete
Let me know if any of the code is unclear.
Option Explicit ' Forces declaration of variables
Dim FilePath, SummaryFilePath '<-- Need set to some value!
FilePath = ""
SummaryFilePath = ""
Dim ExcelObj : Set ExcelObj = CreateObject("Excel.Application")
Dim ConfigFile : Set ConfigFile = ExcelObj.Workbooks.Open(FilePath)
Dim ConfigSheet : Set ConfigSheet = ConfigFile.Worksheets("Scripts")
Dim ConfigApplicationSheet : Set ConfigApplicationSheet = ConfigFile.Worksheets("Applications")
Dim ExecutiveSummarySheet : Set ExecutiveSummarySheet = ConfigFile.Worksheets("Summary")
ExcelObj.ThisWorkbook.SaveAs SummaryFilePath
DeleteSheet ConfigFile, "Summary"
Function DeleteSheet(ByRef WorkbookObj, ByVal SheetNameNotToDelete)
Dim oWorksheet
For Each oWorksheet In WorkbookObj.Worksheets
If oWorksheet.Name <> SheetNameNotToDelete And WorkbookObj.Worksheets.Count >=2 Then
oWorksheet.Delete ' Excel won't let you delete all worksheets from a workbook
End If ' the check on Count >=2 covers the case where no worksheet exists
Next ' called "Summary" to be left
End Function
I want to combine the functionalities of two codes. My first code is converting a csv file to an excel file and saving it with a different name.
I want to add a functionality of deleting the entire row in a file where column A is #N/A. There may be a small thing to fix it but I am not able to work
it out because I am not good at it.
file = "C:\PR\TEST\Sizetest.csv"
Set fso = CreateObject("Scripting.FileSystemObject")
txt = fso.OpenTextFile(file).ReadAll
fso.OpenTextFile(file, 2).Write Replace(Replace(txt, "¬", vbTab), Chr(34), "")
'Set obj = CreateObject("Scripting.FileSystemObject") 'Calls the File System Object
Const xlDelimited = 1
Const xlNormal = -4143
Dim Excel
Set Excel = CreateObject("Excel.Application")
With Excel
.Workbooks.Open "C:\PR\TEST\Sizetest.csv"
.Sheets(1).Columns("A").TextToColumns .Range("A1"), xlDelimited, , , , True 'semicolon-delimited
.ActiveWorkbook.SaveAs .ActiveWorkbook.Path & "\Size_test1", xlNormal
.Quit
' fso.DeleteFile("C:\PR\TEST\Sizetest.csv") 'Deletes the file throught the DeleteFile function
End With
This is the second code. This should delete entire row whereever there is #N/A in column A. I want the record to be deleted either before the file is
converted to Excel or after it is converted to Excel so it does not matter at what point it should convert it.
I got the following code by searching in the Google but due to not being good at VB script, I am not able to combine them two files. I tried different ways but I am getting one error or another.
Sub macro2()
Dim i As Long, lcol As Long
Application.DisplayAlerts = False
With Worksheets("Sheet1")
lcol = .Range("A1"). End(xLToRight).Column
For i = lcol To 1 Step -1
If.Cells(1, i).Value = "#N/A" Then .Rows(i).Delete
Next i
End With
Application.DisplayAlerts = True
End Sub
Thanks in advance
Updated Code Only to delete #N/A
Sub DeleteErrorRows()
'The path to the workbook in which to search.
'Defining the variables
Dim MyPath, MySheet,MyWB
MyPath = "C:\PR\TEST\Sizetest.xls"
'The name of the workbook in which to search.
MyWB = "SizeGuideLookup_test.xls"
'Use the current sheet as the place to store the data for which to search.
MySheet = ActiveSheet.Name
'If an error occurs, use the error handling routine at the end of this file.
'On Error GoTo ErrorHandler
'Turn off screen updating, and then open the target workbook.
'Application.ScreenUpdating = False
Const strERROR = "#N/A"
Application.ScreenUpdating = False
Dim i, lastRow, rw
Dim rFound
Dim sList
Workbooks.Open MyPath
'Workbooks.Open FileName:=MyPath & MyWB
set wb = Workbooks.Open(objFile.Mypath, ReadOnly:=True, CorruptLoad:=xlExtractData)
wb.Close
Set sList = CreateObject("System.Collections.Sortedlist")
Set rFound = ActiveSheet.Cells.Find(What:=strERROR, After:=Range("A1"), Lookat:=xlPart,LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
If rFound Is Nothing Then Exit Sub
lastRow = rFound.Row
For i = 1 To lastRow
Set rFound = Rows(i).Find(What :=strERROR, After:=Rows(i).Cells(1, Columns.Count), Lookat:=xlPart, _
LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not rFound Is Nothing Then
If Not sList.ContainsKey(i) Then
sList.Add i, vbNullString
End If
End If
Next
For i = sList.Count - 1 To 0 Step -1
rw = sList.GetKey(i)
Rows(rw).Delete
Next
DeleteErrorRows
Application.ScreenUpdating = True
'conn.close
End Sub
I am getting error on the following line of code. Error says 'Expected End of Statement )' This code seems ok to me. There might be other errors and I am trying to get this program to work. Set rFound = ActiveSheet.Cells.Find(What:=strERROR, After:=Range("A1"), Lookat:=xlPart,LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
Delete all Rows with a #N/A Error from an Excel Worksheet using either VBA or VBScript
Sub RemoveErrorRows(oWorksheet)
Const strERROR = "#N/A"
Const xlValues = -4163
Const xlPart = 2
Const xlByRows = 1
Const xlNext = 1
Dim rFound, lastRow, x
With oWorksheet
Do
Set rFound = .Rows.Find(CStr(strERROR), .UsedRange.Cells(1, .Columns.Count), xlValues, xlPart, xlByRows, xlNext)
If rFound Is Nothing Then
Exit Do
Else
.Rows(rFound.Row).Delete
End If
Loop
End With
End Sub
I need some help please. I have managed to create a task in outlook using VB and SendItem. My problem is the code I'm using is creating two tasks and not just the one I want.
I have tried removing the .Save as I thought this was the cause but it still adds two tasks. I have added breakpoints to the code to ensure its not cycling round twice for some obscure reason and it just executes once.
Would appreciate someone telling me the obvious please
Code snippet:
`If bNotFount = False Then
Set Ns = Application.GetNamespace("MAPI")
Set ItemT = GetCurrentItem()
Set taskFolder = Ns.GetDefaultFolder(olFolderTasks)
Set olTask = Ns.GetDefaultFolder(olFolderTasks).Items.Add(olTaskItem)
With olTask
.Subject = ItemT.Subject
.Attachments.Add ItemT
.Body = ItemT.Body
.DueDate = Now + 1
.Move taskFolder
.Save
.Display 'show the task to add notes
End With
End If'
You don't need to move it to the default task folder because you saving it there anyway.
Just remove .Move taskFolder line.
I updated your code:
Private Sub Application_ItemSend(Item As Object, ByRef Cancel As Boolean) Handles Application.ItemSend
Dim ns As Outlook.NameSpace
Dim taskFldr As Outlook.Folder
Dim olTask As Outlook.TaskItem
' If bNotFount = False Then
Ns = Application.GetNamespace("MAPI")
taskFldr = ns.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderTasks)
olTask = taskFldr.Items.Add
With olTask
.Subject = Item.Subject
.Attachments.Add(Item)
.Body = Item.Body
.DueDate = Now + 1
.Save()
.Display() 'show the task to add notes
End With
' End If
End Sub
Can anyone tell me why the activeworksheet object MCWS is not being created by the following VB Script please? It is the code for a combobox in a mathcad worksheet. Thanks
Public Sub SizeBoxEvent_Start()
Dim objEX
Dim objMC
Dim MCWS
Dim objEXWB
Dim objEXWS
Dim intLineNo
Dim objRange
End Sub
Sub SizeBoxEvent_Exec(Inputs,Outputs)
Set objMC = CreateObject("MathCad.Application")
Set MCWS = objMC.ActiveWorkSheet
Set objEX = CreateObject("Excel.Application")
Set objEXWB = GetObject("C:\UB_Dims.xls")
Set objEXWS = objEXWB.worksheets("UB")
Dim MyList(71)
For i = 0 to 71
Mylist(i) = CStr(objEXWS.cells(i+3,1))
'MsgBox Mylist(i)
Next
SizeBox.List() = MyList
intLineNo = SizeBox.ListIndex + 3
objRange = "A" & intLineNo & ":U" & intLineNo
Dim varDimProps(21)
Dim varDimName(21)
For i = 1 to 21
varDimProps(i) = objEXWS.cells(intLineNo,i)
varDimName(i) = CStr(objEXWS.cells(1,i))
Next
MCWS.SetValue "Size", ABC
MCWS.SetValue "M", 288
MCWS.SetValue "D", 203
Outputs(0).Value = varDimProps
End Sub
Sub SizeBoxEvent_Stop()
Rem TODO: Add your code here
End Sub
I haven't used Public subs, so I don't know if your declarations will carry over to other subs. Here's something I picked from the PTC forum that works in Excel 2007 with Mathcad 15.0 (I understand that the excel add in is broken for later excel versions).
My guess is that you should define your objects in the functions that use them. Also, I don't think you can use Activeworksheet for the MathCad worksheet.
Private Function RunMCAD(InputFile As String)
Dim MC As Object
Set MC = CreateObject("Mathcad.Application")
MC.Visible = True
Set Wk = MC.Worksheets
Set WS = Wk.Open("C:\RDDA\RDDA 2014-10-16_excel.xmcd")
WS.SetValue "InputFile", InputFile
WS.Recalculate
WS.Save
WS.Close False
MC.Quit
RunMCAD = "Done"
End Function
I would like to add a Control and an associated event at runtime in Excel using VBA but I don't know how to add the events.
I tried the code below and the Button is correctly created in my userform but the associated click event that should display the hello message is not working.
Any advice/correction would be welcome.
Dim Butn As CommandButton
Set Butn = UserForm1.Controls.Add("Forms.CommandButton.1")
With Butn
.Name = "CommandButton1"
.Caption = "Click me to get the Hello Message"
.Width = 100
.Top = 10
End With
With ThisWorkbook.VBProject.VBComponents("UserForm1.CommandButton1").CodeModule
Line = .CountOfLines
.InsertLines Line + 1, "Sub CommandButton1_Click()"
.InsertLines Line + 2, "MsgBox ""Hello!"""
.InsertLines Line + 3, "End Sub"
End With
UserForm1.Show
The code for adding a button at runtime and then to add events is truly as simple as it is difficult to find out. I can say that because I have spent more time on this perplexity and got irritated more than in anything else I ever programmed.
Create a Userform and put in the following code:
Option Explicit
Dim ButArray() As New Class2
Private Sub UserForm_Initialize()
Dim ctlbut As MSForms.CommandButton
Dim butTop As Long, i As Long
'~~> Decide on the .Top for the 1st TextBox
butTop = 30
For i = 1 To 10
Set ctlbut = Me.Controls.Add("Forms.CommandButton.1", "butTest" & i)
'~~> Define the TextBox .Top and the .Left property here
ctlbut.Top = butTop: ctlbut.Left = 50
ctlbut.Caption = Cells(i, 7).Value
'~~> Increment the .Top for the next TextBox
butTop = butTop + 20
ReDim Preserve ButArray(1 To i)
Set ButArray(i).butEvents = ctlbut
Next
End Sub
Now you need to add a Class Module to your code for the project. Please remember it's class module, not Standard Module.
The Object butEvents is the button that was clicked.
Put in the following simple code (in my case the class name is Class2).
Public WithEvents butEvents As MSForms.CommandButton
Private Sub butEvents_click()
MsgBox "Hi Shrey from " & butEvents.Caption
End Sub
That's it. Now run it!
Try this:
Sub AddButtonAndShow()
Dim Butn As CommandButton
Dim Line As Long
Dim objForm As Object
Set objForm = ThisWorkbook.VBProject.VBComponents("UserForm1")
Set Butn = objForm.Designer.Controls.Add("Forms.CommandButton.1")
With Butn
.Name = "CommandButton1"
.Caption = "Click me to get the Hello Message"
.Width = 100
.Top = 10
End With
With objForm.CodeModule
Line = .CountOfLines
.InsertLines Line + 1, "Sub CommandButton1_Click()"
.InsertLines Line + 2, "MsgBox ""Hello!"""
.InsertLines Line + 3, "End Sub"
End With
VBA.UserForms.Add(objForm.Name).Show
End Sub
This permanently modifies UserForm1 (assuming you save your workbook). If you wanted a temporary userform, then add a new userform instead of setting it to UserForm1. You can then delete the form once you're done with it.
Chip Pearson has some great info about coding the VBE.
DaveShaw, thx for this code man!
I have used it for a togglebutton array (put a 'thumbnail-size' picture called trainer.jpg in the same folder as the excel file for a togglebutton with a picture in it). In the 'click' event the invoker is also available (by the object name as a string)
In the form:
Dim CreateTrainerToggleButtonArray() As New ToggleButtonClass
Private Sub CreateTrainerToggleButton(top As Integer, id As Integer)
Dim pathToPicture As String
pathToPicture = ThisWorkbook.Path & "\trainer.jpg"
Dim idString As String
idString = "TrainerToggleButton" & id
Dim cCont As MSForms.ToggleButton
Set cCont = Me.Controls.Add _
("Forms.ToggleButton.1")
With cCont
.Name = idString
.Width = 20
.Height = 20
.Left = 6
.top = top
.picture = LoadPicture(pathToPicture)
End With
ReDim Preserve CreateTrainerToggleButtonArray(1 To id)
Set CreateTrainerToggleButtonArray(id).ToggleButtonEvents = cCont
CreateTrainerToggleButtonArray(id).ObjectName = idString
End Sub
and a class "ToggleButtonClass"
Public WithEvents ToggleButtonEvents As MSForms.ToggleButton
Public ObjectName As String
Private Sub ToggleButtonEvents_click()
MsgBox "DaveShaw is the man... <3 from your friend: " & ObjectName
End Sub
Now just simple call from UserForm_Initialize
Private Sub UserForm_Initialize()
Dim index As Integer
For index = 1 To 10
Call CreateTrainerToggleButton(100 + (25 * index), index)
Next index
End Sub
This was my solution to add a commandbutton and code without using classes
It adds a reference to allow access to vbide
Adds the button
Then writes a function to handle the click event in the worksheet
Sub AddButton()
Call addref
Set rng = DestSh.Range("B" & x + 3)
'Set btn = DestSh.Buttons.Add(rng.Left, rng.Top, rng.Width, rng.Height)
Set myButton = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", Left:=rng.Left, Top:=rng.Top, Height:=rng.Height * 3, Width:=rng.Width * 3)
DoEvents
With myButton
'.Placement = XlPlacement.xlFreeFloating
.Object.Caption = "Export"
.Name = "BtnExport"
.Object.PicturePosition = 1
.Object.Font.Size = 14
End With
Stop
myButton.Object.Picture = LoadPicture("F:\Finalised reports\Templates\Macros\evolution48.bmp")
Call CreateButtonEvent
End Sub
Sub addref()
On Error Resume Next
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Program Files (x86)\Common Files\Microsoft Shared\VBA\VBA6\VBE6EXT.OLB"
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6EXT.OLB"
End Sub
Private Sub CreateButtonEvent()
On Error GoTo errtrap
Dim oXl As Application: Set oXl = Application
oXl.EnableEvents = False
oXl.DisplayAlerts = False
oXl.ScreenUpdating = False
oXl.VBE.MainWindow.Visible = False
Dim oWs As Worksheet
Dim oVBproj As VBIDE.VBProject
Dim oVBcomp As VBIDE.VBComponent
Dim oVBmod As VBIDE.CodeModule '
Dim lLine As Single
Const QUOTE As String = """"
Set oWs = Sheets("Contingency")
Set oVBproj = ThisWorkbook.VBProject
Set oVBcomp = oVBproj.VBComponents(oWs.CodeName)
Set oVBmod = oVBcomp.CodeModule
With oVBmod
lLine = .CreateEventProc("Click", "BtnExport") + 1
.InsertLines lLine, "Call CSVFile"
End With
oXl.EnableEvents = True
oXl.DisplayAlerts = True
Exit Sub
errtrap:
End Sub
An easy way to do it:
1 - Insert a class module and write this code:
Public WithEvents ChkEvents As MSForms.CommandButton
Private Sub ChkEvents_click()
MsgBox ("Click Event")
End Sub
2 - Insert a userform and write this code:
Dim Chk As New Clase1
Private Sub UserForm_Initialize()
Dim NewCheck As MSForms.CommandButton
Set NewCheck = Me.Controls.Add("Forms.CommandButton.1")
NewCheck.Caption = "Prueba"
Set Chk.ChkEvents = NewCheck
End Sub
Now show the form and click the button
I think the code needs to be added to the Userform, not to the button itself.
So something like
With UserForm1.CodeModule
'Insert code here
End With
In place of your With ThisWorkbook