How to put the programmatically generated workbook an event code similar to below:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim nextTarget As Range
Set nextTarget = Range(Selection.Address) 'store the next range the user selects
Target.Columns.Select 'autofit requires columns to be selected
Target.Columns.AutoFit
nextTarget.Select
End Sub
Use this to add a workbook and place a worksheet change event into the Sheet1 module.
Sub AddSht_AddCode()
Dim wb As Workbook
Dim xPro As VBIDE.VBProject
Dim xCom As VBIDE.VBComponent
Dim xMod As VBIDE.CodeModule
Dim xLine As Long
Set wb = Workbooks.Add
With wb
Set xPro = .VBProject
Set xCom = xPro.VBComponents("Sheet1")
Set xMod = xCom.CodeModule
With xMod
xLine = .CreateEventProc("Change", "Worksheet")
xLine = xLine + 1
.InsertLines xLine, " Cells.Columns.AutoFit"
End With
End With
End Sub
When you 1st run the code you may get an error.
Hit the Stop Icon and select the tools menu and "References"
Then find "Microsoft Visual Basic for Applications Extensibility 5.3 library" and check it.
Run the code again and it should work.
Related
I created a workbook that is automated with macro and I want to copy the whole workbook and paste it into another workbook and remove all macro's (including the form controls) except only the formulas.
My code is working copying the workbook and pasting to another workbook (including the formulas) and removing the macros. But the Form controls were still keep on appearing in the new workbook. What code do I need to add? Please help me. My code is written below:
Private Sub Label16_Click()
Unload Me
Dim NewWkb As Workbook
Dim xWkb As Workbook
Dim x As Integer
Set xWkb = Workbooks("Technical Support Database (Automated by MACRO).xlsb")
Set NewWkb = Workbooks.Add
NewWkb.SaveAs "C:\Users\TSJeddah\OneDrive - Delta Marketing Co\JIM FILES\Operation Files\" & "TS Database (No MACRO).xlsx"
For x = 1 To xWkb.Worksheets.Count - 1
xWkb.Sheets(x).Copy after:=NewWkb.Worksheets(NewWkb.Worksheets.Count)
Next x
End Sub
If you need to remove all form controls from the target workbook, you can do so with the following code:
Sub DeleteFormControlsFromWB(WB As Workbook)
Dim sh As Shape, ws As Worksheet
For Each ws In WB.Worksheets
For Each sh In ws.Shapes
If sh.Type = msoFormControl Or sh.Type = msoOLEControlObject Then
Debug.Print "Deleted Form control: " & sh.Name 'debug
sh.Delete
End If
Next
Next
End Sub
Sub UsageExample()
DeleteFormControlsFromWB ThisWorkbook
End Sub
Private Sub Label16_Click()
Unload Me
Dim NewWkb As Workbook
Dim xWkb As Workbook
Dim x As Integer
Set xWkb = Workbooks("Technical Support Database (Automated by
MACRO).xlsb")
Set NewWkb = Workbooks.Add
NewWkb.SaveAs "C:\Users\TSJeddah\Desktop\JIM\" & "TS Database (No
MACRO).xlsx"
Call UsageExample
For x = 1 To xWkb.Worksheets.Count - 1
xWkb.Sheets(x).Copy
after:=NewWkb.Worksheets(NewWkb.Worksheets.Count)
Next x
ActiveWorkbook.Close
Application.ScreenUpdating = True
End Sub
Basically, I want my program to open a hyperlink to another workbook and copy a range of values onto my original workbook. The problem is, I don't know how to properly reference the workbook to "paste" onto
I've tried to replicate a lot of different internet examples. I've tried using "Set" and "With" to switch between them and I've tried to make the original workbook the active workbook before pasting and nothing has been working.
Private Sub findColumns_button_Click() 'userform code
Dim index As Integer, hyperlink_A As Variant, Wb As Worksheet, mainWorkbook As Variant
mainWorkbook = ActiveWorkbook.FullName
Worksheets("Data").Cells(2, 2) = ResultA_Combo.Value
index = findIndex(Cells(2, 2).Value)
hyperlink_A = findHyperlink(index)
Worksheets("Data").Cells(3, 2) = hyperlink_A
Workbooks.Open Filename:=hyperlink_A 'opens correctly
Dim test As Double
test = Worksheets("Data").Range("S23")
MsgBox test 'displays correct value from desired workbook
Workbooks.Activate Filename:=mainWorkbook 'not sure what to do here
End Sub
MsgBox test returns the desired value but I can't find a way to set a cell value in the original workbook equal to test
See if this helps, I've edited your code, and by comparing I hope you get in the right direction... see comments in code for more details:
Private Sub findColumns_button_Click() 'userform code
Dim index As Integer, hyperlink_A As Variant, Wb As Worksheet, mainWorkbook As Workbook
Dim wbSrc As Workbook
Set mainWorkbook = ActiveWorkbook
With mainWorkbook.Worksheets("Data")
.Cells(2, 2) = ResultA_Combo.Value
index = findIndex(.Value)
hyperlink_A = findHyperlink(index)
.Cells(3, 2) = hyperlink_A
End With
Set wbSrc = Workbooks.Open(Filename:=hyperlink_A) 'Allocate to variable and open at the same time
Dim test As Double
test = mainWorkbook.Worksheets("Data").Range("S23")
MsgBox test 'displays correct value from first workbook
mainWorkbook.Activate 'as long you fully qualify the ranges, you don't need and should avoid as much as possible to use .Activate & .Select
Dim test2 As Double
wbSrc.Worksheets(1).Range("A1") = mainWorkbook.Worksheets("Data").Range("S23") * 2
test2 = wbSrc.Worksheets(1).Range("A1")
MsgBox test2 'displays correct value from second workbook
End Sub
Using Excel 2007, I understand that I can create worksheet_change event on the worksheet it's created.
But how do I assign a global sub change events to a newly created worksheet?
e.g.
Public Sub DataChange(ByVal Target As Range)
' this will check and see if the user or operator has change the column field
' if they fill in "X", mark the whole row to red color
' otherwise leave it black
Dim KeyCells As Range
Dim LastRow As Long
LastRow = Cells(Rows.Count, 1).END(xlUp).Row
Set KeyCells = Range("L2:L" & LastRow)
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
If Target.Value = "X" Or Target.Value = "x" Then
Target.EntireRow.Font.color = vbRed
Else
Target.EntireRow.Font.color = vbBlack
End If
End If
End Sub
Then in a separate sub procedure in Module1...
Public Sub CreateWorkSheet()
Dim ws As Worksheet
Set ws = Sheets.Add
ws.Name = "Test1"
' Here where I want to set the event but I do not know the syntax
' ws.OnChange = DataChange
Debug.Print "Done"
End Sub
I'm used to assign events on the fly when creating controls (C#/WPF/Pascal), so I figured there would be one in Excel world. Any advice or help would be greatly appreciated.
As mentioned by Jeeped, probably the easiest way would be to copy the sheet that already had the Private Sub Worksheet_Change code behind it, but there is also another way, if you place the following code under ThisWorkbook, whenever a new sheet is created it will add the desired code behind it:
Private Sub Workbook_NewSheet(ByVal Sh As Object)
Dim NewSheet As Worksheet
Set NewSheet = Sheets(ActiveSheet.Name)
Code = "Private Sub Worksheet_Change(ByVal Target As Range)" & vbCrLf
Code = Code & "MsgBox ""your code here""" & vbCrLf
Code = Code & "End Sub"
With ThisWorkbook.VBProject.VBComponents(NewSheet.Name).CodeModule
NextLine = .CountOfLines + 1
.InsertLines NextLine, Code
End With
End Sub
The drawback here is that the Trust Settings for Macros would need to be changed by clicking on the Trust access to the VBA project object model:
EDIT:
You could also copy code from one worksheet to another using a similar method:
Sub test()
Dim CodeCopy As VBIDE.CodeModule
Dim CodePaste As VBIDE.CodeModule
Dim numLines As Long
Set CodeCopy = ActiveWorkbook.VBProject.VBComponents("Sheet1").CodeModule
Set CodePaste = ActiveWorkbook.VBProject.VBComponents("Sheet2").CodeModule
numLines = CodeCopy.CountOfLines
'Use this line to erase all code that might already be in sheet2
'If CodePaste.CountOfLines > 1 Then CodePaste.DeleteLines 1, CodePaste.CountOfLines
CodePaste.AddFromString CodeCopy.Lines(1, numLines)
End Sub
I'd go for the last #Jeeped's suggestion
place this code in ThisWorkbook code pane
Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
DataChange Target ' this sub will be called at any change of any worksheet passing the chenged range
End Sub
then place this in the same code pane or in any other Module
Public Sub DataChange(ByVal Target As Range)
' this will check and see if the user or operator has change the column field
' if they fill in "X", mark the whole row to red color
' otherwise leave it black
Dim KeyCells As Range
Set KeyCells = Range("L2:L" & Cells(Rows.Count, 1).End(xlUp).Row)
If Not Application.Intersect(KeyCells, Target) Is Nothing Then Target.EntireRow.Font.color = IIf(UCase(Target.Value2) = "X", vbRed, vbBlack)
End Sub
I have this code:
For a = 1 To 5
strFoglio = "SheetName" & a
Sheets.Add
ActiveSheet.Name = strFoglio
ActiveSheet.Move after:=Sheets(Sheets.Count)
Next a
Is there a way to write code on these brand new sheets for example:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim myRange As Range
End sub
Naturally, I'd like to do directly in the For...Next loop and not manually.
The code below will run your For loop, create 5 sheets, and per sheet will call a Sub CodeCopy which will copy the code lines from a Module (in this example the code in "Sheet1") into the new created sheet.
Code
Option Explicit
Sub CreateSheets()
Dim a As Long
For a = 1 To 5
Sheets.Add
ActiveSheet.Name = "SheetName" & a
ActiveSheet.Move after:=Sheets(Sheets.Count)
Call CodeCopy(ActiveSheet.Name)
Next a
End Sub
' **********
Sub CodeCopy(DestShtStr As String)
' Macro to copy the macro module from sheet1 to a new Sheet
' Name of new sheet is passed to the Sub as a String
' Must install "Microsoft Visual Basic for Applications Extensibility library"
' from Tools > References.
Dim i As Integer
Dim SrcCmod As VBIDE.CodeModule
Dim DstCmod As VBIDE.CodeModule
' set source code module to code inside "Sheet1"
Set SrcCmod = ActiveWorkbook.VBProject.VBComponents(ActiveWorkbook.Worksheets("Sheet1").CodeName).CodeModule
Set DstCmod = ActiveWorkbook.VBProject.VBComponents(ActiveWorkbook.Worksheets(DestShtStr).CodeName).CodeModule
' copies all code line inside "Sheet1"
' can be modified to a constant number of code lines
For i = 1 To SrcCmod.CountOfLines
DstCmod.InsertLines i, SrcCmod.Lines(i, 1)
Next i
End Sub
Code in "Sheet1" that will be copied to all new created sheets is:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim myRange As Range
End Sub
Instructions
In order for this code to work, you need to allow the following 2 things:
Go to Tools >> References, and add a reference to "Microsoft Visual Basic for Applications Extensibility" library (screen-shot below)
In Excel Main menu, go to Developer Menu, then select Macro Security, the click V to allow "Trust access to the VBA project object model" (screen-shot below)
If i understand well, you want to create code directly on the new sheets created with your initial code.
So i would do like this :
Code(1) = Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Code(2) = Dim myRange As Range
Code(3) = '....
For i = 1 To 3
Wb.VBProject.VBComponents("SheetName & a").CodeModule.InsertLines i, Code(i)
Next i
(Just put it in loop)
Title is fairly self-explanatory, the goal is to use VBA on Sheet1 to Copy the contents of a Cell in Sheet 2, in this example Cell "U6", and Paste the copied text into Sheet1's Module.
The reason for copying text from a worksheet into a module in this case (and I'm sure this can be done in several perhaps more efficient ways, but for the sake of trying, I wish to stick to this method for this issue) is that the Cell on Sheet2 contains a Formula that arranges multiple lines of VBA syntax with several variables determined by other features in the WorkBook together into a brief line of code (four lines). Copying the result from Sheet2 into the Module for Sheet2 is desirable in this scenario.
For methods attempted, as the code source is on a Worksheet and does not yet live within a Module, unless I'm mistaken, I do not believe VBIDE would be an applicable solution.
Thank you.
So you can achieve this by 2 methods. I have written both below. You can use either of the one
Sub Copy()
'Method 1
Sheets("Sheet2").Range("U6").Copy
Destination:=Sheets("Sheet1").Range("A1")
'Method 2
'Copy the data
Sheets("Sheet2").Range("U6").Copy
'Activate the destination worksheet
Sheets("Sheet1").Activate
'Select the target range
Range("A1").Select
'Paste in the target destination
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub
No idea why you'd want to, but.....
Add a reference in the VBE to Microsoft Visual Basic For Applications Extensibility 5.3.
Enable programmatic access to the VBA Project.
In Excel 2010 select the Developer tab and click the Macro Security button.
Under macro settings tick Trust access to the VBA project object model.
Use code similar to this:
Sub AddProcedureToModule()
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Dim LineNum As Long
Dim x As Long
Set VBProj = ActiveWorkbook.VBProject
Set VBComp = VBProj.VBComponents("Sheet1")
Set CodeMod = VBComp.CodeModule
x = 1
With CodeMod
LineNum = .CountOfLines + 1
.InsertLines LineNum, "Public Sub MyProcedureName()"
LineNum = LineNum + 1
Do While Sheet1.Cells(x, 1) <> ""
.InsertLines LineNum, " " & Sheet1.Cells(x, 1)
x = x + 1
LineNum = LineNum + 1
Loop
.InsertLines LineNum, "End Sub"
End With
End Sub
This will copy whatever is in Sheet1 column A into the VBE.
http://www.cpearson.com/excel/vbe.aspx
Edit:
After re-reading your question, this code will add the value in U6 as a comment to the bottom of any code in Sheet1 module:
Sub AddCommentModule()
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Dim LineNum As Long
Set VBProj = ActiveWorkbook.VBProject
Set VBComp = VBProj.VBComponents("Sheet1")
Set CodeMod = VBComp.CodeModule
With CodeMod
LineNum = .CountOfLines + 1
.InsertLines LineNum, "'" & Sheet1.Range("U6")
End With
End Sub
Note - in these instances, Sheet1 is the sheets codename and not necessarily the name that appears on the sheet tab. To use that use ThisWorkbook.Worksheets("Sheet1"). instead of just Sheet1.
Edit 2 (as I'm waiting for 5:30pm to go home):
Add this code into Sheet1 module and it will auto-update the comments whenever you type into cell U6:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$U$6" Then
AddCommentModule
End If
End Sub