In my userform, users can enter numbers in a textbox (2 maximum).
The number then gets copied in a worksheet.
I'm trying to have any number entered in this textbox to get copied but with the number 6 at the end.
If the user enter '.14'; then in the worksheet, I need to see '.16'.
If the user enter '.45'; then in the worksheet, I need to see '.46'.
And so on..
The only exception, is If the user enter '6' in the textbox, then in the worksheet, I need to ONLY see '.6', and not '.66'. (this problem was fixed thanks to an answer received earlier : VBA to ignore cell formating when adding a specific number using a userform)
I've used cell formating and entered ''.06'' In 'Type'. I thought It worked, but then when I enter let's say '.43' in the userform, the number that gets copied in the cell is not '.46' like expected, but ''.56''.
I dont know why.
EDIT :
I tried this but it's not working :
Sub ReplaceLastDigit()
Dim r As Range
Application.ScreenUpdating = False
For Each r In Range("C4", Range("C" & Rows.Count).End(xlUp))
If IsNumeric(r) And Len(r) > 1 Then
r = Left(r, Len(r) - 1) & "6"
End If
Next r
Application.ScreenUpdating = True
End Sub
EDIT 2:
Everything works, except one thing. When it's only ".6", it doesn't add ".66" (great), but it adds a zero. So I see ".60". Is it the formating?
This is the code :
If Left(TextBox3.Text, 1) <> 6 Then
Sheets("Sheet3").Range("C4").Select
Selection.Borders.Weight = xlThin
ActiveCell.Value = "." & Left(TextBox3.Text, 1) & 6
Else
Sheets("Sheet3").Range("C4").Select
Selection.Borders.Weight = xlThin
ActiveCell.Value = ".6"
End If
Here is the correction to my code that made it work :
If Left(TextBox3.Text, 1) <> 6 Then
Sheets("Sheet3").Range("C4").NumberFormat = "#"
Sheets("Sheet3").Range("C4").Select
Selection.Borders.Weight = xlThin
ActiveCell.Value = "." & Left(TextBox3.Text, 1) & 6
Else
Sheets("Sheet3").Range("C4").NumberFormat = "#"
Sheets("Sheet3").Range("C4").Select
Selection.Borders.Weight = xlThin
ActiveCell.Value = ".6"
End If
Related
Good afternoon,
I have another problem related to IF statement.
I have the following code:
Sub BOMNewRow()
If Range("D38").Value <> "" Or Range("C38") <> "x" Or Range("C38") <> "0" Then
'Inserting new Core Drill row + formula autofill from the previous one
Range("A38").EntireRow.Insert
Range("A38").Value = "First Core drill into building or existing chamber (per event)"
Range("B38").Value = "Sitec"
If Range("D39").Value Like "*2*" Or Range("C39").Value = 2 Then
Range("C38").Value = 2
Else
Range("C38").Value = 1
End If
Range("E38").Value = 100.39
Range("F37").Select
Selection.AutoFill Destination:=Range("F37:F38"), Type:=xlFillDefault
'customizing new row
With Range("A38:B38,D38:F38")
.Borders(xlEdgeTop).Weight = xlThin
.Borders(xlEdgeBottom).Weight = xlThin
End With
With Range("C38")
.Borders(xlEdgeBottom).Weight = xlMedium
End With
Else
Call AuditCheck 'go straight away to the BoM audit control
'Taking a look on one of the audit cell
End If
If Range("C39").Value <> "x" Or Range("C39").Value <> "0" Then
Range("C39").Value = "x"
Range("D38").Value = Range("D39")
Call New_version2
Sheets("BoM").Activate
Else
Call AuditCheck
End If
Range("A43").Select
End Sub
What I intend to do is:
insert the new row 38 and customize it - this is done by my first IF statement.
run the second IF statement based on the cell C39, which doesn't work.
If previously I had the X value in the cell C38, now when I inserted a new row the second IF statement still executes the process for value C39, which is X.
.
It looks like I don't understand the if statement order within the macro.
How can I solve this problem?
Hey I have been writing some code to add a part ID to a spreadsheet off of a user form in Excel VBA. I have been reading through different documentation and can not figure out why no matter what type of method of inserting a row I try it inserts a row with a repeating value instead of a blank one. If anyone knows how to specify blank, other than writing the whole row to blank and then writing my numbers I want after, that would be appreciated.
I have tried both the following lines to add a row
Cells (x+1 ,column).EntireRow.Insert Shift:= xlDown
ws1.Rows(x+1).Insert Shift:=xlDown
This is the function it is used in:
Public Sub Add(IDRange As Range)
SearchCell = Cells(x, IDRange.Column)
Cells(x, IDRange.Column).Select
Do
If SearchCell = PartID Then
MsgBox " this Company Already uses this part"
Exit Sub
ElseIf x <> StopRow Then
x = x + 1
SearchCell = Cells(x, IDRange.Column)
End If
Loop While x <> StopRow And SearchCell <> PartID
Cells(x + 1, IDRange.Column).EntireRow.Insert Shift:=xlDown
Cells(x, IDRange.Column).Value = PartID
MsgBox PartID & " has been added to Adress " & Cells(x, IDRange.Column).Address
Cells(x, IDRange.Column).Select
End Sub
Bellow is the function that calls the Add Function and where I belive it may be getting the company name from
Private Sub AddPart_Click()
AddPartCounter = 0
Company = UserForm1.CompanyBox.Value
PartID = UserForm1.PartBox.Value
If Company = "" Then
MsgBox " Please put in the company you would like the part to go under"
ElseIf PartID = "" Then
MsgBox " Please put in the Part you would like entered"
ElseIf UserForm1.Studs.Value = False And UserForm1.Spreaders.Value = False And UserForm1.Blocks.Value = False And UserForm1.Imma.Value = False Then
MsgBox "Please select the type of part you are trying to add"
Else
Dim CurrentCell
Set CurrentCell = Cells.Find(What:=Company, LookAt:=xlWhole)
If CurrentCell Is Nothing Then
MsgBox " Company Not Found "
Exit Sub
End If
x = CurrentCell.Row
Do
Set CurrentCell = CurrentCell.Offset(1, 0)
Loop While CurrentCell.Offset(1, 0) = "" And Not CurrentCell Is Nothing And CurrentCell.Offset(1, 0).Row <> thisvar.Row + 1
StopRow = CurrentCell.Row
'If they are trying to add a nut
If UserForm1.Imma.Value = True Then
Call Add(Nut_ID_Rng)
'IF they are trying to add a stud
ElseIf UserForm1.Studs.Value = True Then
Call Add(Stud_ID_Rng)
'If they are trying to add a block
ElseIf UserForm1.Blocks.Value = True Then
Call Add(Block_ID_Rng)
'If they are trying to add a spreader
ElseIf UserForm1.Spreaders.Value = True Then
Call Add(Spreader_ID_Rng)
End If
End If
AddPartCounter = 1
End Sub
I know that the repeating pattern is coming from the insert line through debugging but I can not figure out why I have tried changing variables to numbers and it still did the same thing. This what it looks like with the repeating values.
enter image description here
The problem is that you most likely have a value still stored in your clipboard when you execute the Macro. To fix that, simply add this line of dode before running the insert line:
Applcation.CutCopyMode = False
That will clear your clipboard and allow the inserted rows to be blank.
I have an Excel VBA procedure which is supposed to compare the values of two cells. In my case they are scalars, ranging from 1 to 3. Basically, they are answers to questions. If they match, then I want to color a certain cell green, otherwise I want to make it red. Is there something wrong with my syntax?
Sub CheckBold()
'
' CheckBold Macro
'
'
Row = ActiveCell.Row
If ThisWorkbook.Sheets(1).Range("D" & CStr(ActiveCell.Row)).Font.Bold Then
ActiveCell.Value = 1
End If
If ThisWorkbook.Sheets(1).Range("E" & CStr(ActiveCell.Row)).Font.Bold Then
ActiveCell.Value = 2
End If
If ThisWorkbook.Sheets(1).Range("F" & CStr(ActiveCell.Row)).Font.Bold Then
ActiveCell.Value = 3
End If
ActiveCell.Value = ThisWorkbook.Sheets(3).Range("A" & CStr(ActiveCell.Row)).Value & ActiveCell.Value
If CInt(ActiveCell.Value) = CInt(ThisWorkbook.Sheets(3).Range("A" & CStr(ActiveCell.Row)).Value) Then
ActiveCell.Interior.Color = RGB(0, 180, 0)
Else
ActiveCell.Interior.Color = RGB(180, 0, 0)
End If
End Sub
What happens is that always the code goes on the Then branch of the if, even though the values are different. Why do I get this behavior?
I had a piece of code commissioned earlier this week (cheaper to have an expert write it than for me to spend a week trying to!). However, when putting it use I've hit a bit of a snag.
The macro looks at a name on one excel worksheet, matches it to a list of names and associated ID numbers on a different worksheet, then inserts the ID on the first worksheet. This was all fine until I started using it on real data.
Here's some sample data (all of this information is in one cell...):
WARHOL*, Andy
PETO, John F
D3 GRECO, Emilio -20th C
HASELTINE, William Stanley
D3 DALI, Salvador
D3 SOSNO, Sacha
WEGMAN**, WILLIAM
One asterisk means it's a print, two a photograph, D3 a sculpture, and nothing a painting.
When I run the code with this data, it sees * as a wildcard, and so will always insert the ID of the first variation of the artist in the sheet. What I need is a way for the macro to not read it as a wildcard.
I did some research, and found that inserting ~ before * negates the wildcard properties. How would I make my code do this? I've discovered the main issue of having code written by someone else... You might not understand it!
Here is the code:
Public Sub match_data()
'ctrl+r
On Error GoTo errh
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim r1, r2, i, exc As Long
Dim fp As Range
Sheets("Data").Activate
r1 = Cells(Rows.Count, "B").End(xlUp).Row
r2 = Sheets("List").Cells(Sheets("List").Rows.Count, "B").End(xlUp).Row
'MsgBox r1 & r2
exc = 0
For i = 2 To r1
If Range("B" & i).Value <> "" Then
With Sheets("List").Range("B2:B" & r2)
Set fp = .Find(Range("B" & i).Value, LookIn:=xlValues, lookat:=xlWhole)
If Not fp Is Nothing Then
Range("B" & i).Interior.Color = xlNone
Range("A" & i).Value = Sheets("List").Range("A" & fp.Row).Value
Else
Range("B" & i).Interior.Color = xlNone
Range("B" & i).Interior.Color = vbYellow
exc = exc + 1
End If
End With
End If
Next i
MsgBox "There are " & exc & " exceptions."
errh:
If Err.Number > 0 Then
MsgBox Err.Description
End If
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Oh also, I would need to do this for the list of names and ID's wouldn't I? If so, that only needs doing once, so if you could give me a hint about that too, I'd be so grateful!
Thanks!
PS I know the system we are using at the moment absolutely sucks (definitely not 3rd form normalised!), but we are fast running out of time and money, and need to get our product up and running ASAP!
EDIT: To clarify, here is a pic of the spreadsheets I'm working with... Obviously in cells A14 and A15 I wanted the ID numbers 11 & 12 respectively
Here is one way to tell the stars from the planets:
Sub StaryNight()
Dim s As String, OneStar As String, TwoStar As String, ThreeStar As String
OneStar = "*"
TwoStar = "**"
ThreeStar = "***"
t = Range("A1").Text
ary = Split(t, ",")
s = ary(0)
If Right(s, 3) = ThreeStar Then
MsgBox "scupture"
Exit Sub
ElseIf Right(s, 2) = TwoStar Then
MsgBox "photograph"
Exit Sub
ElseIf Right(s, 1) = OneStar Then
MsgBox "print"
Exit Sub
End If
MsgBox "Painting"
End Sub
Okay, I have solved the problem! I had a play around with changing the variables in the Find and Replace box.
If I put ~* in both the find AND replace boxes, and uncheck Match entire cell contents, I can replace all of the * with ~* (really don't understand that but oh well!)
So I do this on the Data worksheet, but NOT on the List worksheet, run the macro as normal and the problem is solved!
I have written an Excel VBA to copy data from selected cells from one workbook sheet to another. Here it is working fine upto certain cells, after pasting some values, after sometime VBA is pasting empty values. I mean eventhough the source cell is not empty, it is pasting empty values. I have put breakpoint and saw, but the value was there. Please help me to solve this issue.
The code is as follows.
Set objClickScriptWB = objExcelWB.Workbooks.Open(SourceWBPath)
For intSheet = 9 To 12 'objClickScriptWB.Worksheets.Count
If InStr(1, objClickScriptWB.Worksheets(intSheet).Name, "SC", vbTextCompare) > 0 Then
blnScriptSheet = 1
objClickScriptWB.Worksheets(intSheet).Activate
For r = 24 To objClickScriptWB.Worksheets(intSheet).UsedRange.Rows.Count
If Trim(LCase(objClickScriptWB.Worksheets(intSheet).Cells(r, 6).Value)) <> Trim(LCase("Transaction")) And Trim(LCase(objClickScriptWB.Worksheets(intSheet).Cells(r, 6).Value)) <> Empty And objClickScriptWB.Worksheets(intSheet).Cells(r, 6).MergeArea.Cells.Count = 1 Then
objClickScriptWB.Worksheets(intSheet).Cells(r, 6).Select
If blnCompSht = 0 Then
Set objComparisonSheet = ThisWorkbook.Worksheets.Add
objComparisonSheet.Name = "Comparison"
objComparisonSheet.Activate
objComparisonSheet.Cells(2, 2).Value = "Clickscript Transaction names"
i = 3
objExcelWB.Selection.Copy
objComparisonSheet.Activate
objComparisonSheet.Cells(i, 2).Select
'Sheet3.Range("B2").Select
'objComparisonSheet.Range("B" & i).PasteSpecial Paste:=xlPasteValues
objComparisonSheet.Paste
'Sheet2.Range("G2").Cells
i = i + 1
blnCompSht = 1
'Application.Wait (Now + TimeValue("00:00:01"))
ElseIf blnCompSht = 1 Then
ThisWorkbook.Worksheets("Comparison").Activate
Dim LastRow As Integer
For intRow = 2 To ThisWorkbook.Worksheets("Comparison").Rows.Count
If ThisWorkbook.Worksheets("Comparison").Cells(intRow, 2).Value = Empty Then
i = intRow
Exit For
End If
Next
objExcelWB.Selection.Copy
ThisWorkbook.Worksheets("Comparison").Cells(i, 2).Select
'ThisWorkbook.Worksheets("Comparison").Range("B" & intRow).PasteSpecial Paste:=xlPasteValues
ThisWorkbook.Worksheets("Comparison").Paste
i = i + 1
'Application.Wait (Now + TimeValue("00:00:01"))
End If
'End If
'Next
'Call CompareTxnNames(objClickScriptWB.Worksheets(intSheet).Name)
End If
'Next
Next
End If
Next
End Sub
Please help me
Thanks
You could also directly apply the value of one cell to the other cell with a code like this:
CellTarget.Value2 = CellSource.Value2
Or in your case:
objComparisonSheet.Cells(i, 2).Value2 = objClickScriptWB.Worksheets(intSheet).Cells(r, 6).Value2
Side note:
Get into the habit of using Value2 for that is the true value of the cell compared to Value which is the value with formatting applied to it. The latter is slower and in case of date values can give wrong days and months when you arent using the US dateformat in your excel.