Convert decimal into percent - VBA - vba

I'm trying to convert number in decimal format in my selection to percentages but am getting a type mismatch error.
Current code is below, where lRow is predefined integer.
Range("F6:F" & lRow).Select
Selection.Value = Selection.Value / 100
Selection.NumberFormat = "0.0%_);(0.0%)"

The issue is here:
Selection.Value = Selection.Value / 100
I am assuming that Selection typically contains more than one cell, in which case .Value does not return a number that can be divided but rather an array containing the value of each individual cell. Use a For Each loop to go through the set of cells in the selection and apply the calculation:
For Each cel In Selection
cel.Value = cel.Value /100
Next
Also note that you don't need to select cells as if you were using Excel mouse input to do things in VBA. It is better to do something like
Dim rng As Range
Set rng = Range("F6:F" & lRow)
and then use rng where you currently use Selection, for example rng.NumberFormat = ...

One approach is to use PasteSpecial with xlPasteSpecialOperationDivide :
With Range("F6:F" & lRow)
With Range("F" & lRow + 1)
.Value = 100 'put 100 to a helper cell
.Copy 'put divider into the clipboard
End With
.PasteSpecial xlPasteValues, xlPasteSpecialOperationDivide 'divide all the values by divider in the clipboard
.NumberFormat = "0.0%_);(0.0%)"
End With
Range("F" & lRow + 1).ClearContents 'clear the helper cell

Related

Excel VBA Loop That Not Stops Based On Activecell Value

I have a loop that needs to stop when activecell value is "BBSE", but it passes the cell and continues the loop. someone can help me with that?
I cut rows from table in one workbbok and paste it to another. before the list in column F I have many blank cells, and because of that I am usind xldown.
Here is the relevant code:
'Illuminators Worksheet
OP_wb.Activate
Range("F2").End(xlDown).Select
Do Until ActiveCell.Value = "BBSE"
OP_wb.Activate
Worksheets("Optic Main").Activate
Range("F2").End(xlDown).Select
Selection.EntireRow.Cut
Demand_WB.Activate
Worksheets("Illuminators").Activate
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
Loop
Here is where I want to stop the loop in the red circle:
this is why I am using END.xlDown
If I understand what you are trying to achieve correctly, I believe the following will achieve it:
Dim startRow As Long
Dim endRow As Long
With OP_wb.Worksheets("Optic Main")
startRow = .Range("F2").End(xlDown).Row
endRow = .Columns("F").Find(What:="BBSE", LookIn:=xlValues, LookAt:=xlWhole).Row
.Rows(startRow & ":" & endRow).Cut
End With
With Demand_WB.Worksheets("Illuminators")
.Range("A" & .Rows.Count).End(xlUp).Offset(1).Insert Shift:=xlDown
End With
May be try like this...
'Mentioning Starting Row Here
x = 2
Do
'x refers to Row and F refer to column name
With Cells(x, "F")
'Exiting Do Loop once it finds the matching value using If statement
If .Value = "BBSE" Then Exit Do
OP_wb.Activate
Worksheets("Optic Main").Activate
.EntireRow.Cut
Demand_WB.Activate
Worksheets("Illuminators").Activate
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
End With
'Incrementing row number here to move on to next row
x = x + 1
Loop

Select first visible cell directly beneath the header of a filtered column

I am trying to select the first visible cell directly beneath the header of a filtered column. The code I am getting is as below, but I have to problems with this code. First, the first line of code is using the current active range of the file. It is highly likely that this file will change and this range will not be the same. How can I make it work for any file I would use it on? Second, if I use a totally different file with the same column format, the first visible cell under Column J could be J210. How can I make this work for any array of variables?
Sub Macro16()
'
' Macro16 Macro
'
'
ActiveSheet.Range("$A$1:$R$58418").AutoFilter Field:=12, Criteria1:= _
"Sheets"
Range("J2").Select
ActiveCell.FormulaR1C1 = "=RIGHT(RC[1],3)"
Selection.FillDown
End Sub
Sub FirstVisibleCell()
With Worksheets("You Sheet Name").AutoFilter.Range
Range("A" & .Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Select
End With
End Sub
Untested but:
Sub Macro16()
With ActiveSheet.Range("A1").CurrentRegion
.AutoFilter field:=12, Criteria1:="Sheets"
If .Columns(1).SpecialCells(xlCellTypeVisible).count > 1 Then
With .Columns(10)
.Resize(.rows.count - 1).offset(1).SpecialCells(xlCellTypeVisible).FormulaR1C1 = "=RIGHT(RC[1],3)"
End With
End If
End With
End Sub
I prefer non-destructive methods of determining whether there are visible cells to work with after a filtering operation. Since you are filling in column J with a formula, there is no guarantee that column J contains any values tat can be counted with the worksheet's SUBTOTAL function (SUBTOTAL does not count rows hidden by a filter) but the formula you are planning to populate into column J references column K so there must be something there.
Sub Macro16()
With ActiveSheet
If .AutoFilterMode Then .AutoFilterMode = False
With .Cells(1, 1).CurrentRegion
.Columns(12).AutoFilter Field:=1, Criteria1:="Sheets"
With .Resize(.Rows.Count - 1, 1).Offset(1, 9)
If CBool(Application.Subtotal(103, .Offset(0, 1))) Then
.SpecialCells(xlCellTypeVisible).FormulaR1C1 = "=RIGHT(RC[1],3)"
End If
End With
.Columns(12).AutoFilter Field:=1
End With
End With
End Sub
      
Something like this might work...
Sub Macro16()
Dim ARow As Long, JRow As Long, ws1 As Worksheet
ws1 = Sheets("NAME OF SHEET WITH DATA")
ARow = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row + 1
ws1.Range("$A$1:$R$" & ARow).AutoFilter Field:=12, Criteria1:="Sheets"
JRow = ws1.Range("J" & ws1.Rows.Count).End(xlUp).Row + 1
ws1.Range("J" & JRow).FormulaR1C1 = "=RIGHT(RC[1],3)"
ws1.Range("J" & JRow).FillDown
End Sub

Modify a copy script to retain the formatting

I have a copy script that works perfectly, with the exception to losing my formatting when it runs. I lose the horizontally and vertically centered text, cell background color (for conditions), all of my borders, and any text effects (bold/underline/italic). For adding uniform borders, I use
Range("CSResults").Borders.LineStyle = xlContinuous
While this works, not all of the borders are the same thickness and the cell background color varies depending on the contents of the cell.
I need to modify my current script to keep the formatting.
Copy Script
Dim SectionCS As Long, NextRow As Long, TotalRows As Long
Sheets("CS Results").Activate
Range("CSResults").Select
Selection.AutoFilter
Range("CSResults").Clear
For SectionCS = 1 To 13 '36
NextRow = Sheets("CS Results").Range("A" & Rows.Count).End(xlUp).Row + 1 'Next empty row
Sheets("Function Test Procedure - CS").Activate
TotalRows = Range("CSSec" & SectionCS).Rows.Count
Sheets("CS Results").Range("A" & NextRow).Resize(TotalRows, 14).Value = _
Range("CSSec" & SectionCS).Columns("A:N").Value
Next SectionCS
You're not technically copy/pasting, you're setting values equal. To paste the data and the format, use pasteSpecial:
Range("CSSec" & SectionCS).Columns("A:N").Copy
With Sheets("CS Results").Range("A" & NextRow).Resize(TotalRows, 14)
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False
That should work, just double check the copy range is accurate.

VBA Look through List

I've got the following code which gets the word dividend from a column and then takes the whole row and copy pastes it to a new sheet.
Sub SortActions()
Dim i&, k&, s$, v, r As Range, ws As Worksheet
Set r = [index(a:a,match("###start",a:a,),):index(a:a,match("###end",a:a,),)].Offset(, 6)
k = r.Row - 1
v = r
For i = 1 To UBound(v)
If LCase$(v(i, 1)) = "dividend" Then
s = s & ", " & i + k & ":" & i + k
End If
Next
s = Mid$(s, 3)
If Len(s) Then
Set ws = ActiveSheet
With Sheets.Add(, ws)
ws.Range(s).Copy .[a1]
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Sheets("20140701_corporate_action_servi").Select
Rows("2:2").Select
Selection.Copy2
Range("C32").Select
Sheets("Sheet11").Select
ActiveSheet.Paste
End With
End If
End Sub
Is there a way to make this dynamic. So if I want to search for more than word. For example if I have several rows with dividends and special dividends -> it would take all rows of dividends and all rows of special dividends and put them in separate sheets. I have tried ti with recording a macro it doesn't work as the words can differ. Maybe getting the content into a list would work. Please assist . Thanks
As suggested by #Macro Man , I am submitting images of an example sheet and sheet after filter with a simple macro for filtering one field. Please all credit to #Macro Man, it is for illustration in a simple way.
Simple code as follows.
Sub Filter1Field()
With Sheet1
.AutoFilterMode = False
With .Range("A1:H13")
.AutoFilter
.AutoFilter Field:=5, Criteria1:="Dividend"
End With
End With
End Sub
*****UPDATE*******
If your other criteria such as "Sp. Dividend" is other field but on the same row as shown in the image appended and you wish to copy to other sheet you can use the code given below. Another image shows results obtained on sheet2. You can adopt the code to your requrements.
You can use this code:
Sub Test2()
Dim LastRow As Long
Sheets("Sheet2").UsedRange.Offset(0).ClearContents
With Worksheets("Sheet1")
.Range("A1:H13").AutoFilter
.Range("A1:H13").AutoFilter field:=5, Criteria1:="Dividend"
.Range("A1:H13").AutoFilter field:=6, Criteria1:="=Sp. Dividend"
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A1:A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
Destination:=Sheets("Sheet2").Range("A1")
End With
End Sub

Determine and list all values within a given range and list in one cell as a comma delimited value

I am trying to find a way to list unique values in a given year range, and list the results in one cell as a comma delimited value. In the example below, Column A contains the data that I have, and Column B is the desired result.
Column A | Column B
2007-2010 | 2007,2008,2009,2010
1999-2001 | 1999,2000,2001
The direction that I was thinking about going in was to find the difference between the two numbers and fill series from the first number based on the difference. Then concatenate the values in one cell with a comma delimiter. So, based on that, here is what I have so far:
LR = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Range("B1").Select
ActiveCell.FormulaR1C1 = "=RIGHT(RC[-1],4)-LEFT(RC[-1],4)"
Range("B1").Select
Selection.AutoFill Destination:=Range("B1:B" & LR), Type:=xlFillDefault
Range("C1").Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[-2],4)"
Range("C1").Select
Selection.AutoFill Destination:=Range("C1:C" & LR), Type:=xlFillDefault
I am not married to this approach, so feel free to steer me in a different direction.
Thanks in advance!
Straight VBA answer like this. Change rStart to be the first cell of your data:
Sub SplitYears()
Dim rStart As Range, lRow As Long, lYear1 As Long, lYear2 As Long
Set rStart = Sheet3.Range("A1")
lRow = 0
Do While rStart.Offset(lRow, 0).Value <> ""
' Get start and end year
lYear1 = CLng(Left(rStart.Offset(lRow, 0).Value, 4))
lYear2 = CLng(Right(rStart.Offset(lRow, 0).Value, 4))
With rStart.Offset(lRow, 1)
.ClearContents
.NumberFormat = "#"
' Append each year with comma
Do While lYear1 <= lYear2
.Value = .Value & lYear1 & ","
lYear1 = lYear1 + 1
Loop
' Lose final comma
.Value = Left(.Value, Len(.Value) - 1)
End With
lRow = lRow + 1
Loop
End Sub