Private Sub UpdateBoxes()
Dim wsFunc As WorksheetFunction: Set wsFunc = Application.WorksheetFunction
Dim sheet As String
If Range("C1") = "some string" Then
sheet = "SomeSheet"
End If
Range("B6").Value = Sheets("Spreadsheet Ctrl").Range("B7") 'Sets title of Box 1 based on Spreadsheet Ctrl
Range("G6").Value = Sheets("Spreadsheet Ctrl").Range("C7") 'Sets title of Box 2 based on Spreadsheet Ctrl
Range("B11").Value = Sheets("Spreadsheet Ctrl").Range("D7") 'Sets title of Box 3 based on Spreadsheet Ctrl
Range("G11").Value = Sheets("Spreadsheet Ctrl").Range("E7") 'Sets title of Box 4 based on Spreadsheet Ctrl
Range("B16").Value = Sheets("Spreadsheet Ctrl").Range("F7") 'Sets title of Box 5 based on Spreadsheet Ctrl
Range("G16").Value = Sheets("Spreadsheet Ctrl").Range("G7") 'Sets title of Box 6 based on Spreadsheet Ctrl
Range("C7").Value = wsFunc.VLookup(B6,'" & sheet & '"!A1:G5,3,)" 'Vlookup for "Current Revision
End Sub
The variable "sheet" will eventually change based on a nested if. It should then be passed to the last line of code before End Sub. I am getting a compile error that states "Expected: expression", and it highlights the first tick in '" & sheet & '".
Something like:
Range("C7").Value = wsFunc.VLookup(ActiveSheet.Range("B6"), _
Sheets(sheet).Range("A1:G5"),3,False)
Related
I have created a macro in Powerpoint that will search for slides that are using a textbox for their title and are replacing them with a Title box. The steps are
1) find the slides that have a textbox in the title area
2) Copy the text in the textbox to a variable called slTitle.
3) Delete the texbox
4) Create a Title Holder for the current slide
5) Copy the text into the Title holder
6) Move on to the next slide
My macro currently is able to get as far as step 4 but I can't figure out how to get the text in slTitle into the Title box. This should be fairly easy to do but I've tried several ways and nothing seems to work. If anyone can help me figure out this step it would be much appreciated.
I am getting a compile error "Invalid Qualifier" on the line:
Set ppPlaceholderTitle.TextFrame.TextRange.Text = slTitle
Here is my current macro.
Sub AddMiMissingTitles()
Dim shpCurrShape As Object
Dim x As Integer
Dim sl As PowerPoint.Slide
Dim sld As Slide
Dim ctr As Integer
Dim s As Shape
'x = ActivePresentation.Slides.Count
'counter ctr used to count number of slides that needed titles added
ctr = 0
'**************************************************************
Set sourcePres = ActivePresentation
x = 1 ' slide counter
'get the title text
For Each sl In sourcePres.Slides
'delete all the empty title text boxes first
For Each s In sl.Shapes
If s.Top < 45 Then ' it's in the title area
'MsgBox s.PlaceholderFormat.Type
If s.Type <> ppPlaceholderTitle Then ' it isn't a proper Title placeholder
If s.HasTextFrame = msoTrue Then
If Trim(s.TextFrame.TextRange.Text) = "" Then
s.Delete ' delete empty text holders
Else
slTitle = s.TextFrame.TextRange.Text
s.Delete
sl.CustomLayout = sl.CustomLayout 'reset the slide
Set ppPlaceholderTitle.TextFrame.TextRange.Text = slTitle
End If
End If
End If
End If
Next
'Is there a title placeholder on the current layout?
If sl.CustomLayout.Shapes.HasTitle Then
lngType = sl.CustomLayout.Shapes.Title.PlaceholderFormat.Type
'*********************************
' With ActivePresentation.Slides()
End If
Next
MsgBox "Done! " & vbCrLf & ctr & " Slides needed Titles."
'*********************************
'sl.Shapes.AddPlaceholder lngType
sl.Shapes.Title.TextFrame.TextRange = slTitle
End Sub
I am tasked with pulling two specific rows of data from monthly sheets in a workbook.
Current code, using MyVal and a search box, is only compatible with one search. How can I change the code & searchbox function to be compatible with multiple searches?
Current code looks like this:
Sub Set_Hyper()
' Object variables
Dim wks As Excel.Worksheet
Dim rCell As Excel.Range
Dim fFirst As String
' {i} will act as our counter
Dim i As Long
' Use an input box to type in the search criteria
Dim MyVal As String
MyVal = InputBox("What are you searching for", "Search-Box", "")
' if we don't have anything entered, then exit the procedure
If MyVal = "" Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Add a heading to the sheet with the specified search value
With Cells(1, 1)
.Value = "Found " & MyVal & " in the Link below:"
.EntireColumn.AutoFit
.HorizontalAlignment = xlCenter
End With
i = 2
' Begin looping:
' We are checking all the Worksheets in the Workbook
For Each wks In ActiveWorkbook.Worksheets
If wks.Name <> "Data" Then
' We are checking all cells, we don't need the SpecialCells method
' the Find method is fast enough
With wks.Range("A:A")
' Using the find method is faster:
' Here we are checking column "A" that only have {myVal} explicitly
Set rCell = .Find(MyVal, , , xlWhole, xlByColumns, xlNext, False)
' If something is found, then we keep going
If Not rCell Is Nothing Then
' Store the first address
fFirst = rCell.Address
Do
' Link to each cell with an occurence of {MyVal}
rCell.Hyperlinks.Add Cells(i, 1), "", "'" & wks.Name & "'!" & rCell.Address
wks.Range("B" & rCell.Row & ":R" & rCell.Row).Copy Destination:=Cells(i, 2)
Set rCell = .FindNext(rCell)
i = i + 1 'Increment our counter
Loop While Not rCell Is Nothing And rCell.Address <> fFirst
End If
End With
End If
Next wks
' Explicitly clear memory
Set rCell = Nothing
' If no matches were found, let the user know
If i = 2 Then
MsgBox "The value {" & MyVal & "} was not found on any sheet", 64, "No Matches"
Cells(1, 1).Value = ""
End If
' Reset application settings
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I'm thinking what you could do is create a UserForm with the following controls:
A text box
A Listbox
A button to add text to the listbox
Another button to run the VBA
The Textbox can hold the search string(s). You can make an event when you click the button to do the following:
1) Add the text from textbox to the listbox. Lookup the AddItem method to do this.
2) Clear the text box contents, so a new value can be added.
Once that's added you can add another for loop around your code to go through each item added to the listbox. That way you can do multiple searches based on what was added.
Hopefully this helps :)
I am working on a macro for a user to click a button and populate a new worksheet where there will be another macro button solely functioning as a PASTE button would, and the user can paste the screenshot with whatever they have copied. Currently, the user clicks a button named "add screen shot", and a input box will populate asking the user what they would like to name the screen shot worksheet. The user writes in a title and a new tab is formed with the name of the worksheet as the user's inputted title. Here is the code to do so:
Sub AddScreenShot()
Dim Title As Variant
Title = Application.InputBox("Enter a Title: ", "Add Screen Shot", , 400, 290, , , Type:=2)
If Title = False Then
Exit Sub
ElseIf Title = vbNullString Then
MsgBox "A title was not entered. Please enter a Title"
Exit Sub
ElseIf Len(Title) > 15 Then
MsgBox "No more than 15 characters please"
Run "AddScreenShot"
Else
ActiveWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count)).name = Title
End If
End Sub
I already have the subroutine that pastes the clipboard image into the active cell within the open sheet:
Sub Paste_Image()
On Error GoTo PasteError
Application.ScreenUpdating = False
Range("E5").Activate
ActiveSheet.Paste
Application.ScreenUpdating = True
ActiveSheet.Unprotect Password:=xxxx
GetOutOfHere:
Exit Sub
PasteError:
MsgBox "Please verify that an image has been copied", vbInformation, "Paste Image"
Resume GetOutOfHere
End Sub
The issue is I do not know how to link these two snippets of code together, so that when the user enters the title of the sheet and clicks OK, the new sheet populates with a macro button that will run the paste subroutine above. Any suggestions on linking the two, and making the paste sub run when the user click OK to create a new worksheet?
Thanks.
You can create the button at at runtime.
Using this method, you programmatically add a button when the sheet is created.
Dim btn As Button
Application.ScreenUpdating = False
Dim t As Range
Dim sht As Sheet 'Added to ensure we don't add duplicate sheets
Set t = ActiveSheet.Range(Cells(1, 1))
Set btn = ActiveSheet.Buttons.Add(t.Left, t.Top, t.Width, t.Height)
With btn
.OnAction = "Paste_Image" 'Calls the Paste_Image subroutine when clicked
.Caption = "Paste" 'Change caption as you see fit
.Name = "btnPaste" 'Change name as you see fit
End With
Next i
Application.ScreenUpdating = True
So your full code should look something like this:
Sub AddScreenShot()
Dim Title As Variant
Dim btn As Button
Dim t As Range
Dim sht As Worksheet
Title = Application.InputBox("Enter a Title: ", "Add Screen Shot", , 400, 290, , , Type:=2)
If Title = False Then
Exit Sub
ElseIf Title = vbNullString Then
MsgBox "A title was not entered. Please enter a Title"
Exit Sub
ElseIf Len(Title) > 15 Then
MsgBox "No more than 15 characters please"
Run "AddScreenShot"
Else
On Error Resume Next
Set sht = ActiveWorkbook.Worksheets(Title)
On Error GoTo 0
If Not sht Is Nothing Then
MsgBox "A worksheet named " & Title & " already exists!"
Run "AddScreenShot"
Else
Application.ScreenUpdating = False
ActiveWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Title
Set t = ActiveSheet.Range("A1:B2") 'Button will appear in cell A1:B2, change to whatever you want.
Set btn = ActiveSheet.Buttons.Add(t.Left, t.Top, t.Width, t.Height) 'This will make the button the size of the cell, may want to adjust
With btn
.OnAction = "Paste_Image" 'Calls the Paste_Image subroutine when clicked
.Caption = "Paste" 'Change caption as you see fit
.Name = "btnPaste" 'Change name as you see fit
End With
Application.ScreenUpdating = True
End If
End If
End Sub
Very new at VBA, I need something that sounds simple but I lack the knowledge or terminology to correctly research how to do this.
I need a way to loop through a column (we'll say D) to find value (X) and prompt a dropdown box from range (T2:T160) to replace value X for each individual occurance of X in rows rows 1 to 10000.
At the same for each time X is found, the value in that row for column B needs to be displayed (the user will query an external application to determine which of the values from the range needs to be set for that unique column B value)
1 b
2 y
3 x
4 t
5 x
and end like this
1 b
2 y
3 q
4 t
5 p
I setup my data like this:
Main code:
Sub findReplace()
Dim iReply As Integer
Dim strName As String
strName = InputBox(Prompt:="Enter Text to Search in Column D", Title:="Search Text", Default:="Enter value to find")
If strName = "Enter value to find" Or strName = vbNullString Then
Exit Sub
Else
For Each cell In Range("D1:D5")
If cell.Value = Trim(strName) Then
'Prompt to see if new value is required
iReply = MsgBox(Prompt:="Found " & strName & vbCrLf & "Value in column B is: " & cell.Offset(0, -2).Value & vbCrLf & "Do you wish to replace it?", _
Buttons:=vbYesNoCancel, Title:="UPDATE MACRO")
'Test response
If strName = "Your Name here" Or _
strName = vbNullString Then
Exit Sub
ElseIf iReply = vbYes Then
'Get new value
UserForm1.Show
ValueSelected = UserForm1.ComboBox1.Value
Unload UserForm1
If ValueSelected = vbNullString Or ValueSelected = "" Then
Exit Sub
Else
'Replace value
cell.Value = ValueSelected
End If
ElseIf iReplay = vbCancel Then
Exit Sub
End If
End If
Next cell
End If
End Sub
Setup a UserForm1 to display a drop down list to provide the user a selection option. Code behind form looks like this: (buttons have to be named the same to work correctly)
Private Sub bnt_Cancel_Click()
Unload Me
End Sub
Private Sub btn_Okay_Click()
Me.Hide
End Sub
Private Sub UserForm_Initialize()
'Populate dropdown list in userform
Dim rng As Range
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
For Each rng In ws.Range("T1:T10")
Me.ComboBox1.AddItem rng.Value
Next rng
End Sub
When you run it you'll get this sequence of popups:
I said no to the second replacement value so now my spread sheet looks like this:
I want to display to the user certain information that exists on a separated worksheet, whenever he clicks a button.
I can set Excel to "go" to this worksheet at the starting line of the range , but I could not find a way to hide everything else.
Is there some method for this, or do I have to hide all rows and columns?
Insert a UserForm in the Workbook's VB Project.
Add a ListBox control to the userform.
Then do something like this code in the UserForm_Activate event code:
Private Sub UserForm_Activate()
Dim tbl As Range
Set tbl = Range("B2:E7") '## Change this to capture the rang you need '
Me.Caption = "Displaying data from " & _
ActiveSheet.Name & "!" & tbl.Address
With ListBox1
.ColumnHeads = False
.ColumnCount = tbl.Columns.Count
.RowSource = tbl.Address
End With
End Sub
Which gives unformatted data from the range:
To export the range as an image, you could create an Image in the UserForm instead of a Listbox. Then this should be enough to get you started.
As you can see from this screenshot, the image might not always come out very clearly. Also, if you are working with a large range of cells, the image might not fit on your userform, etc. I will leave figuring that part out up to you :)
Private Sub UserForm_Activate()
Dim tbl As Range
Dim imgPath As String
Set tbl = Range("B2:E7") '## Change this to capture the rang you need '
imgPath = Export_Range_Images(tbl)
Caption = "Displaying data from " & _
ActiveSheet.Name & "!" & tbl.Address
With Image1
If Not imgPath = vbNullString Then
.Picture = LoadPicture(imgPath)
.PictureSizeMode = fmPictureSizeModeClip
.PictureAlignment = 2 'Center
.PictureTiling = False
.SpecialEffect = 2 'Sunken
End If
End With
End Sub
Function Export_Range_Images(rng As Range) As String
'## Modified by David Zemens with
' credit to: _
' http://vbadud.blogspot.com/2010/06/how-to-save-excel-range-as-image-using.html ##'
Dim ocht As Object
Dim srs As Series
rng.CopyPicture xlScreen, xlPicture
ActiveSheet.Paste
Set ocht = ActiveSheet.Shapes.AddChart
For Each srs In ocht.Chart.SeriesCollection
srs.Delete
Next
'## Modify this line as needed ##'
fname = "C:\users\david_zemens\desktop\picture.jpg"
On Error Resume Next
Kill fname
On Error GoTo 0
ocht.Width = rng.Width
ocht.Height = rng.Height
ocht.Chart.Paste
ocht.Chart.Export Filename:=fname, FilterName:="JPG"
Application.DisplayAlerts = False
ocht.Delete
Application.DisplayAlerts = True
Set ocht = Nothing
Export_Range_Images = fname
End Function
If you record a macro and hide some columns and rows manually, the code will be produced for you, and you will see how it's done.