I'm trying to concatenate Tier Code and Cap Code where Cap Level = 2. I was able to successfully do the concatenation earlier using a case statement, without the condition that Cap Level = 2. However, now that I'm trying to add that condition, I keep getting the error "Type Mistmatch". I've tried setting Range("E3:E24").Value = 2 and = "2". Both ways, I still get the error.
My data currently looks like this:
I've been playing around with this for at least an hour now and reading other questions about case statements with multiple conditions/criteria, but I haven't been able to get my code to work properly.
Sub Concat_ParentCode_Cap1_001()
With Worksheets("PD Code Structure")
Dim ParentCode As Range
Dim TierCode As String
Dim CapCode As String
CapCode = "FS_CAP_1_001"
TierCode = "FS_Tier_1"
Set ParentCode = Range("F3:F24")
Select Case True
Case CapCode = "FS_CAP_1_001" And Range("E3:E24").Value = "2"
ParentCode = TierCode & "." & CapCode
End Select
End With
End Sub
I would like my data to look like this:
There are a few things in the code provided that will cause it not too work, but the main thing is a loop to check each cell.
Give this a shot:
Option Explicit
Sub Concat_ParentCode_Cap1_001()
Dim tierCode As String
tierCode = "FS_TIER_1."
With Worksheets("PD Code Structure")
Dim capCode As Range
For Each capCode In .Range("F2:F24")
If Len(capCode.Offset(, -1)) Then
Dim capParent As String
capParent = capCode.Value
End If
If capCode.Offset(, -2).Value = 2 Then
capCode.Offset(, -1).Value = tierCode & capParent
End If
Next
End With
End Sub
Do you really need to use VBA for this ? This looks like something you can do with just an if statement on excel. =if(B2=2,CONCAT(A1,".",D1),""). This is of course assuming the columns are listed A-D above.
Related
From ActiveWorkbook.name, I would like to extract the strings that are before (left side of ) the numbers. Since I want to use the same code in multiple workbooks, the file names would be variable, but every file name has date info in the middle (yyyymmdd).
In case of excel file, I can use the below formula, but can I apply the same kind of method in VBA?
=LEFT(A1,MIN(FIND({0,1,2,3,4,5,6,7,8,9},ASC(A1)&1234567890))-1)
Example: MyExcelWorkbook_Management_20200602_MyName.xlsm
In above case, I want to extract "MyExcelWorkbook_Management_".
The most basic thing you could do is to replicate something that worked for you in Excel through Evaluate:
Sub Test()
Dim str As String: str = "MyExcelWorkbook_Management_20200602_MyName.xlsm"
Debug.Print Evaluate(Replace("=LEFT(""X"",MIN(FIND({0,1,2,3,4,5,6,7,8,9},ASC(""X"")&1234567890))-1)", "X", str))
End Sub
Pretty? Not really, but it does the job and got it's limitations.
You could use Regular Expressions to extract any letters / underscores before the number as well
Dim str As String
str = "MyExcelWorkbook_Management_20200602_MyName.xlsm"
With CreateObject("vbscript.regexp")
.Pattern = "^\D*"
.Global = True
MsgBox .Execute(str)(0)
End With
Gives:
MyExcelWorkbook_Management_
So basically you want to use the Midfunction to look for the first numerical character in your input string, and then cut your input string to that position.
That means we need to loop through the string from left to right, look at one character at a time and see if it is a digit or not.
This code does exactly that:
Option Explicit
Sub extratLeftText()
Dim someString As String
Dim result As String
someString = "Hello World1234"
Dim i As Long
Dim c As String 'one character of your string
For i = 1 To Len(someString)
c = Mid(someString, i, 1)
If IsNumeric(c) = True Then 'should write "If IsNumeric(c) = True AND i>1 Then" to avoid an "out of bounds" error
result = Left(someString, i - 1)
Exit For
End If
Next i
MsgBox result
End Sub
Last thing you need to do is to load in some workbook name into your VBA function. Generally this is done with the .Name method of the workbookobject:
Sub workbookName()
Dim wb As Workbook
Set wb = ActiveWorkbook
MsgBox wb.Name
End Sub
Of course you would need to find some way to replace the Set wb = ActiveWorkbook line with code that suits your purpose.
Program: Excel 2016.
I have a sheet with a lot of shapes. Each of them has its own specific name and most of them are label. I want to change their caption property, but i can't find a way but calling them one by one like this:
LblLabel_1.Caption = ...
LblLabel_2.Caption = ...
LblLabel_3.Caption = ...
Instead i was looking for something like this:
For BytCounter01 = 1 to 255
Shapes("LblLabel_" & BytCounter01).Caption = ...
Next
This one will result in error 438, basically saying Caption is not avaiable for this object. It still target the object, since this code:
Debug.print Shapes("LblLabel_" & BytCounter01).Name
will return me its name.
Looking for a solution:
-i've tried Controls("LblLabel_" & BytCounter01) instead of Shapes("LblLabel_" & BytCounter01) but it won't work since Controls is only for userforms, not for sheets;
-i've tried Shapes("LblLabel_" & BytCounter01).TextFrame.Characters.Text but it returns error 438 again;
-since the label is a part of a group, i've tried both
Shapes("ShpGroupOfShapes01").GroupItems(ShpShapeIndex).Caption
and
Shapes("ShpGroupOfShapes01").GroupItems(ShpShapeIndex).TextFrame.Characters.Text
but got 438 again.
Is there really no way to easily target a specific label on a sheet and change his caption?
Thank you.
EDIT: thanks to Excelosaurus, the problem is solved. Since my labels are ActiveX Controls i have to use something like this:
For BytCounter01 = 1 to 255
Shapes("LblLabel_" & BytCounter01)OLEFormat.Object.Object.Caption = ...
Next
You can check his response and comments for more details. Thanks again Excelosaurus!
To change the textual content of a shape, use .TextFrame2.TextRange.Text as shown below:
shtShapes.Shapes(sShapeName).TextFrame2.TextRange.Text = sShapeCaption
where shtShapes is the name of your worksheet's object as seen from the Visual Basic Editor in the Project Explorer,
sShapeName is a string variable containing the name of the target shape, and
sShapeCaptionis a string variable containing the desired caption.
A code example follows. I've thrown in a function to check for a shape's existence on a worksheet, by name.
Option Explicit
Public Sub SetLabelCaptions()
Dim bCounter As Byte
Dim sShapeName As String
Dim sShapeCaption As String
For bCounter = 1 To 255
sShapeName = "LblLabel_" & CStr(bCounter)
If ShapeExists(shtMyShapes, sShapeName) Then
sShapeCaption = "Hello World " & CStr(bCounter)
shtMyShapes.Shapes(sShapeName).TextFrame2.TextRange.Text = sShapeCaption
Else
Exit For
End If
Next
End Sub
Public Function ShapeExists(ByVal pshtHost As Excel.Worksheet, ByVal psShapeName As String) As Boolean
Dim boolResult As Boolean
Dim shpTest As Excel.Shape
On Error Resume Next
Set shpTest = pshtHost.Shapes(psShapeName)
boolResult = (Not shpTest Is Nothing)
Set shpTest = Nothing
ShapeExists = boolResult
End Function
The result should look like this:
You can't assign a Caption to a Shape. (Shapes don't have Captions). One approach is to loop over the Shapes and build a little table to tell you what to loop over next:
Sub WhatDoIHave()
Dim kolumn As String, s As Shape
Dim i As Long, r As Range
kolumn = "Z"
i = 1
For Each s In ActiveSheet.Shapes
Set r = Cells(i, kolumn)
r.Value = i
r.Offset(, 1).Value = s.Name
r.Offset(, 2).Value = s.Type
r.Offset(, 3).Value = s.TopLeftCell.Address(0, 0)
i = i + 1
Next s
End Sub
Which for my sample produced:
Seeing that I have both Forms and ActiveX (OLE) Controls, I know what to loop over next. I then refer to the Control by number and assign a Caption if appropriate.
It is very simple but yet I can't figure it out. Maybe because it cannot be done? Regardless here we go:
I would like to use a combobox that will, when selected, input cells with text values, functions and reference to external cells.
First line of the options would be to have the name populated.
Second line is a formula that would change from course to course.
Third line would provide a cell with a reference to another cell's content from another file. So if multiple course file are used I can have one master file that if I change the content of a cell the change will reflect on all the course file cells that are referring to it once updated.
This is in crude code form what I would like it to perform.
Private Sub ComboBox1_Change()
If Me.ComboBox1.Value = "ITCourse" Then
Worksheets("PARADE STATE").Range("I1").Value = "ITCourse"
Worksheets("Data Base").Range("C1").Value = IF(V9>70,"Prep Week",IF(V9>65,"Week 1",IF(V9>60,"Week 2",IF(V9>55,"Week 3",IF(V9>50,"Week 4",IF(V9>45,"Week 5",IF(V9>40,"Week 6",IF(V9>35,"Week 7",IF(V9>30,"Week 8",IF(V9>25,"Week 9",IF(V9>20,"Week 10",IF(V9>15,"Week 11",IF(V9>10,"Week 12",IF(V9>5,"Week 13",IF(V9>0,"Week 14")))))))))))))))
Worksheets("Week 1").Range("B2").Value = 'N:\ITcourse\00 - Data Base\[ITcourse.xlsx]Sheet'!$A$3
End If
If Me.ComboBox1.Value = "HRCourse" Then
Worksheets("PARADE STATE").Range("I1").Value = "HRCourse"
Worksheets("Data Base").Range("C1").Value = IF(V9>40,"Prep Week",IF(V9>35,"Week 1",IF(V9>30,"Week 2",IF(V9>25,"Week 3",IF(V9>20,"Week 4",IF(V9>15,"Week 5",IF(V9>10,"Week 6",IF(V9>5,"Week 7",IF(V9>5,"Week 8")))))))))
Worksheets("Week 1").Range("B2").Value = 'N:\ITcourse\00 - Data Base\[HRcourse.xlsx]Sheet'!$A$3
End If
End Sub
Thank you!
You need a function that returns the number of weeks for any given course name. This function should use a Dictionary to store the information, and the dictionary may be loaded from a dedicated worksheet.
Function WeeksPerCourse(courseName As String) As Long
Static dict As Scripting.Dictionary
If dict Is Nothing Then
' Fill the dictionary here. Note that it is better
' to load the values from a dedicated, hidden worksheet
Set dict = CreateObject("Scripting.Dictionary")
dict("ITCourse") = 14
dict("HRCourse") = 8
' Etc...
End If
WeeksPerCourse = dict(courseName)
End Function
With this function available, your procedure can be simplified like follows:
Private Sub ComboBox1_Change()
Dim course As Sting: course = Trim(ComboBox1.value)
Worksheets("PARADE STATE").Range("I1").value = course
'Dim nWeek As Long
'nWeek = WeeksPerCourse(course) - Worksheets("PARADE STATE").Range("V9").value / 5
'Worksheets("Data Base").Range("C1").value = IIf(nWeek < 1, "Prep Week", "Week " & nWeek)
Worksheets("Data Base").Range("C1").Formula = "= ""Week "" & INT((WeeksPerCourse('PARADE STATE'!I1) - 'PARADE STATE'!V9)/5)"
Worksheets("Week 1").Range("B2").Formula= "='N:\ITcourse\00 - Data Base\[" & course & ".xlsx]Sheet'!$A$3"
End Sub
I used Data Validation to create some drop down lists. Anyone know how to use VBA to select the first iterm in a drop down list?
I tried 'Split' function:
cell.Value = Split(cell.Validation.Formula1, ",")(0)
but it did not work well, it will only work if I put like "option1, option2" in the source in Data Validation window. If I refer the source to a range of options, then it will return with errors.
I guess there should some smarter ways.
Thanks!
Sub test()
Dim adr As String
With Range("c4")
adr = Mid(.Validation.Formula1, 2)
Debug.Print Range(adr).Cells(1, 1)
End With
End Sub
so your answer is:
set c = range("c4")
c.Value = Range(Mid(c.Validation.Formula1, 2)).Cells(1, 1).Value
I'm creating a small piece of VBA code with a specific formula, however it has a couple of if statements, one of which originates a double-line string (with vbNewLine)
The issue is that I can't see the text.
So I wanted to word wrap it, but each time I set the ActiveCell.WrapText = True, nothing happens.
I checked with a message box. I set the WrapText to True, I return the property value with the MessageBox to confirm, and it's still False.
I've been told to use ActiveCell.Rows.AutoFit as well, but AutoFit does nothing if the text isn't wrapped.
Any idea what I might be doing wrong here?
try:
Sub WrapandFit()
ActiveCell.WrapText = True
ActiveCell.EntireRow.AutoFit
End Sub
It worked for me. Make sure that your screenupdating is also set to true.
For me, the code below worked. (only set to change header row, (change range))
ActiveSheet.Range("A1:R1").Select
With Selection
.WrapText = True
End With
UDFs (procedures that use the keyword Function) only return values. They cannot change other parts of the Excel object model, like cell formatting. Only Subroutines (procedures that use the keyword Sub) can do that.
You need to have your cells formatted properly before you enter your UDF. Or you could use a worksheet change event sub to format them after the fact.
Turn off/On word wrap for whole sheet row can be done by VB code shown below:
If the first row is set true, excel inherits that property for whole sheet, unless you specifically turned it off using another code.
MyWorkSheet.Rows.WrapText = True
To turn off wrapping property of a specific row:
MyWorkSheet.Rows(8).WrapText = False
I suspect that you are trying to wrap text in merged cells. If yes, you cannot simply call:
MyWorkSheet.Rows.WrapText = True
Instead, you have to simulate the wrapping operations. I found the code from http://blog.contextures.com/archives/2012/06/07/autofit-merged-cell-row-height/ helped me last year.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MergeWidth As Single
Dim cM As Range
Dim AutoFitRng As Range
Dim CWidth As Double
Dim NewRowHt As Double
Dim str01 As String
str01 = "OrderNote"
If Not Intersect(Target, Range(str01)) Is Nothing Then
Application.ScreenUpdating = False
On Error Resume Next
Set AutoFitRng = Range(Range(str01).MergeArea.Address)
With AutoFitRng
.MergeCells = False
CWidth = .Cells(1).ColumnWidth
MergeWidth = 0
For Each cM In AutoFitRng
cM.WrapText = True
MergeWidth = cM.ColumnWidth + MergeWidth
Next
'small adjustment to temporary width
MergeWidth = MergeWidth + AutoFitRng.Cells.Count * 0.66
.Cells(1).ColumnWidth = MergeWidth
.EntireRow.AutoFit
NewRowHt = .RowHeight
.Cells(1).ColumnWidth = CWidth
.MergeCells = True
.RowHeight = NewRowHt
End With
Application.ScreenUpdating = True
End If
End Sub
This may not be exactly what the OP had in mind but I figured I'd share my VBA Word Wrap function since I couldn't find anything on the web to do what I wanted.
This function insert CR+LF's into the string in order to wrap it, so the word wrap is maintained if the text is copied to another application, text-based or otherwise.
Function wrapText(strIn As String, Optional maxLen As Long = 110) As String
Dim p As Long: wrapText = strIn
Do
p = InStrRev(wrapText, " ", p + maxLen) - 1
wrapText = Left(wrapText,p) & vbCrLf & Right(wrapText, Len(wrapText)-p-1)
Debug.Print Mid(Replace(wrapText, vbCrLf, "||"), p - 20)
'Stop
Loop While p + maxLen < Len(wrapText)
End Function
It defaults to maximum width of 115 characters but can optionally be changed to anything. It only breaks on spaces (the last one that appears on/before position #115), and it only inserts CR + LF's (with the constant vbCrLf), but they can be adapted as required.
As an example of application, I was building complex SQL queries in Excel and wanted to copy the SQL over to the server app neat & tidy, instead of one giant line.