I know "dd.mm.yyyy" is not formatted as date within Excel, and this conversion part is what is getting to me. I have "31.3.2019" within .cell("C5") and want it to convert within the same cell (replace it) with a new formatting of "3/31/2019". I keep on getting an 'out of range' error and I am not sure where my mistake is.
Below is what I have tried:
Sub DivestitureTemplate_ChangeDateFormat()
Application.ScreenUpdating = False
Dim rng As Range
Dim str() As String
Set rng = Range("C5:C3000")
With Worksheets("Divestiture Template")
For Each rng In Selection
str = Split(rng.Value, ".")
rng.Value = DateSerial(2000 + str(4), str(2), str(0))
Next rng
Selection.NumberFormat = "mm/dd/yyyy"
Application.ScreenUpdating = True
End With
End Sub
Change format of ("C5:C3000") from 31.3.2019 to 3/31/2019 -- it can be continuous, but starting at "C5" as this is an automated report and this is below a specified header. I think I have been looking at this, scripting all day and loosing my head over this for no reason.
To get real dates in the column, try:
Sub DivestitureTemplate_ChangeDateFormat()
Dim cell As Range, rng As Range, d As Date
Set rng = Worksheets("Divestiture Template").Range("C5:C3000")
For Each cell In rng
With cell
arr = Split(.Text, ".")
.Value = DateSerial(arr(2), arr(1), arr(0))
.NumberFormat = "m/dd/yyyy"
End With
Next cell
End Sub
EDIT#1:
Sub DivestitureTemplate_ChangeDateFormat()
Dim cell As Range, rng As Range, d As Date
Dim arr
Set rng = Worksheets("Divestiture Template").Range("C5:C3000")
For Each cell In rng
With cell
arr = Split(.Text, ".")
.Value = DateSerial(arr(2), arr(1), arr(0))
.NumberFormat = "m/dd/yyyy"
End With
Next cell
End Sub
Related
I have a range of values, I want to find the MIN, then highlight the row of this Min value.
Sub worstcase()
Set Rng = .Range("H44:H54")
worstcase = Application.WorksheetFunction.Min(Rng)
Debug.Print worstcase
How can I highlight rows based on variable worstcase?
I have my static range, and find the min value, but now I need to highlight the row of the worstcase variable.
Highlight Row With Found Criteria
The code is highlighting each row where the minimum was found. Use Exit For to highlight only the first found.
The Code
Sub worstcase()
Dim worstcase As Double ' Long for whole numbers.
Dim rng As Range
Dim cell As Range
With Worksheets("Sheet1")
Set rng = .Range("H44:H54")
worstcase = Application.WorksheetFunction.Min(rng)
Debug.Print worstcase
For Each cell In rng
If cell.Value = worstcase Then
cell.EntireRow.Interior.ColorIndex = 3 ' Hightlight whole row.
'cell.Interior.ColorIndex = 5 ' Hightlight only cell.
'Exit For ' To highlight only the first found row.
End If
Next
End With
End Sub
EDIT:
Sub worstcase()
Const cFirst As Variant = "H"
Const cLast As Variant = "Q"
Dim worstcase As Double ' Long for whole numbers.
Dim rng As Range
Dim cell As Range
With Worksheets("Sheet1")
Set rng = .Range("H44:H54")
worstcase = Application.WorksheetFunction.Min(rng)
Debug.Print worstcase
For Each cell In rng
If cell.Value = worstcase Then
.Range(.Cells(cell.Row, cFirst), .Cells(cell.Row, cLast)) _
.Interior.ColorIndex = 3 ' Hightlight cells.
'Exit For ' To highlight only the first found cells.
End If
Next
End With
End Sub
You could do it thus.
Won't work though if you have a repeated minimum.
Also you could use conditional formatting and avoid VBA.
Sub worstcase()
Dim Rng As Range, worstcase, i As Long
Set Rng = Range("H44:H54")
With Rng
worstcase = Application.WorksheetFunction.Min(.Cells)
i = Application.Match(worstcase, .Cells, 0)
.Cells(i).EntireRow.Interior.Color = vbRed
End With
End Sub
Create a conditional formatting rule based on the following formula.
=$H44=min($H$44:$H$54)
This VBA will create a CFR for rows 44:54.
With worksheets("sheet1").range("44:54")
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:="=$H44=min($H$44:$H$54)"
.FormatConditions(.FormatConditions.Count).Interior.Color = vbred
End With
I am new to this forum, so bear with me.
I have a CSV-file that I need to apply some VBA-modules to in order to get the information I need.
In short, I have 3 macros that together to the following:
Create a new row every 20th row
Take the number from the cell above (column A) and fill the blank space in the new row with this number.
Sum the numbers in column H from the 20 rows before the new row to get a total score. This is done subsequently for as long as new rows appear (every 20th row).
Is it possible to get these three macros in a single macro? This would make it easier to hand down to others that may need to use these macros.
Current code:
' Step 1
Sub Insert20_v2()
Dim rng As Range
Set rng = Range("H2")
While rng.Value <> ""
rng.Offset(20).Resize(1).EntireRow.Insert
Set rng = rng.Offset(21)
Wend
End Sub
' Step 2
Sub FillBlanks()
Columns("A:A").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"
End Sub
' Step 3
Sub AutoSum()
Const SourceRange = "H"
Dim NumRange As Range, formulaCell As Range
Dim SumAddr As String
Dim c As Long
For Each NumRange In Columns(SourceRange).SpecialCells(xlConstants, xlNumbers).Areas
SumAddr = NumRange.Address(False, False)
Set formulaCell = NumRange.Offset(NumRange.Count, 0).Resize(1, 1)
formulaCell.Formula = "=SUM(" & SumAddr & ")"
'change formatting to your liking:
formulaCell.Font.Bold = True
formulaCell.Font.Color = RGB(255, 0, 0)
c = NumRange.Count
Next NumRange
End Sub
Thank you for any help.
Best,
Helge
You can create a single Sub calling all the other subs that you have created.
Example:
Sub DoAllTasks()
Insert20_v2
FillBlanks
AutoSum
End Sub
Then you just have to create a button and assign the DoAllTasks to it or run the macro directly.
HTH ;)
That Should'nt be that hard.
Public Sub main()
'deklaration
Dim rng As Range
Const SourceRange = "H"
Dim NumRange As Range, formulaCell As Range
Dim SumAddr As String
Dim c As Long
'Loop trough all Rows
Set rng = Range("H2")
While rng.Value <> ""
rng.Offset(20).Resize(1).EntireRow.Insert
Set rng = rng.Offset(21)
Wend
'Fill the Blank Rows in A
Columns("A:A").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"
For Each NumRange In Columns(SourceRange).SpecialCells(xlConstants, xlNumbers).Areas
SumAddr = NumRange.Address(False, False)
Set formulaCell = NumRange.Offset(NumRange.Count, 0).Resize(1, 1)
formulaCell.Formula = "=SUM(" & SumAddr & ")"
'change formatting to your liking:
formulaCell.Font.Bold = True
formulaCell.Font.Color = RGB(255, 0, 0)
c = NumRange.Count
Next NumRange
End Sub
I just started teaching myself VBA so thanks in advance. Why is this giving me an error? The code searches for the column of dates that are in the future. Then searches in that column for any cells that have a value and colors them yellow.
Thanks!
Sub Macro1()
Dim cell As Range
Dim cell2 As Range
Dim ColumnN As Long
For Each cell In Range("I2:ZZ2")
If cell.Value > Now() Then
'
ColumnN = cell.Column
ColumnL = ConvertToLetter(ColumnN)
MsgBox ColumnL & cell.Row
For Each cell2 In Range("ColumnL:ColumnL")
If Not cell2 Is Empty Then
cell2.Interior.ColorIndex = 6
End If
Next cell2
End If
End Sub()
Function ConvertToLetter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
ConvertToLetter = vArr(0)
End Function
You were almost there!
There's two main problems to fix:
replace:
For Each cell2 In Range("ColumnL:ColumnL")
with
For Each cell2 In Range(ColumnL & ":" & ColumnL)
and
If Not cell2 Is Empty Then
with
If Not IsEmpty(cell2) Then
This should result in the following:
Sub Macro1()
Dim cell As Range
Dim cell2 As Range
Dim ColumnN As Long
Dim ColumnL As String
For Each cell In Range("I2:ZZ2")
If cell.Value > Now() Then
ColumnN = cell.Column
ColumnL = ConvertToLetter(ColumnN)
MsgBox ColumnL & cell.Row
For Each cell2 In Range(ColumnL & ":" & ColumnL)
If Not IsEmpty(cell2) Then
cell2.Interior.ColorIndex = 6
End If
Next cell2
End If
Next cell
End Sub
Function ConvertToLetter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
ConvertToLetter = vArr(0)
End Function
Although it is a little inefficient it gets the job done!
To check if a cell is empty, you need to switch the order of how that's done. Switch your If Not statement to If Not IsEmpty(cell2) Then.
Also, it is highly recommended not to name your variables cell, because this is a close to some "special words" (I forget the technical term) Excel uses. I always just use cel instead.
Sub test()
Dim cel As Range
Dim cel2 As Range
Dim ColumnN As Long
For Each cel In Range("I2:ZZ2")
If cel.Value > Now() Then
ColumnN = cel.Column
' ColumnL = ConvertToLetter(ColumnN)
' MsgBox ColumnL & cell.Row
If Not IsEmpty(cel) Then
cel.Interior.ColorIndex = 6
End If
End If
Next cel
End Sub
Edit: If you notice, I also tweaked your cell2 range. This removed the need to run another macro (which can be a cause of issues sometimes), so you only need the column Number.
Edit2: I removed the "ColumnL" range selection - what is that for? I can add it back in, but wasn't sure why you'd loop through I:ZZ columns, but only have the highlighting in column N.
Edit2:
I tweaked the code, now it's much shorter and should run a bit faster:
Sub Macro2()
Dim cel As Range, rng As Range
Dim lastCol As Long
Application.ScreenUpdating = False
lastCol = Cells(2, 9).End(xlToRight).Column ' Note, this assumes there are NO gaps in the columns from I:ZZ
'lastCol = cells(2,16384).End(xltoleft).column ' use this instead, if there are gaps in I2:ZZ2
Set rng = Range(Cells(2, 9), Cells(2, lastCol))
For Each cel In rng
If cel.Value > Now() Then
cel.Interior.ColorIndex = 6
End If
Next cel
Application.ScreenUpdating = True
End Sub
I would like to return the cell in which a date resides. There is one incidence of each date in column B, formatted dd/mm/yyyy. This is calculated from the cell two above (e.g. using =B3+7).
I have managed to retrieve the date using application.vlookup so I know it's "there". The immediate window gives the correct date using ? activecell.value
I cannot get the range.find function to return anything. If I enter a string with a USA date format such as 09/23/2014 into the column then range.find returns a value, but for UK formatted dates (=23/09/2014) it returns Nothing
Is the range.find function only capable of handling US dates?
Sub columnfind()
Dim DateRow, correctCell As Range
Set DateRow = ActiveSheet.Range("a1:B1000")
Dim strCurrentDate As String
Dim IntDate As Long
IntDate = CLng(CDbl(Now()))
strCurrentDate = Format(Now, "mm/dd/yyyy")
Set correctCell = DateRow.Find(IntDate, LookIn:=xlValues, lookat:=xlPart)
Set correctCell = DateRow.Find(strCurrentDate)
Set correctCell = DateRow.Find(Date)
cell = Application.VLookup(IntDate - 1, ActiveSheet.Range("B1:B1000"), 1, 1)'verify existence of date for my sanity
End Sub
. .
You can use something like:
Range("A1").Select
Application.FindFormat.Clear
Application.FindFormat.NumberFormat = "dd/mm/yy;#"
Set h = Range("A1:A4").Find("21/03", , , , , , , , True)
MsgBox h.Address
You define the format for the date, after use the bool SearchFormat option in the Find method.
If Find() does not work with certain formats, just don't use it:
Sub ColumnFind()
Dim bRng As Range, r As Range
Set bRng = Range("B1:B1000")
For Each r In bRng
If r.Text = "23/9/2014" Then
MsgBox r.Address(0, 0)
End If
Next r
End Sub
or
Sub ColumnFind()
Dim bRng As Range, r As Range
Dim sDate As String
sDate = Format(Date, "dd/m/yyyy")
Set bRng = Range("B1:B1000")
For Each r In bRng
If r.Text = sDate Then
MsgBox r.Address(0, 0)
End If
Next r
End Sub
This is my workaround now, if it is true that range.find doesn't work with non-US dates.
Sub columnfind()
Dim DateCol, correctCell As Range
Set DateCol = ActiveSheet.Range("B1:B1000")
Dim strCurrentDate As String
DateCol.NumberFormat = "mm/dd/yy;#"
strCurrentDate = Format(Now, "mm/dd/yy")
DateCol.Find(strCurrentDate).Select
DateCol.NumberFormat = "m/d/yyyy"
End Sub
I have a Range("B6:T10000")
Data in the range are a mixture of blanks,#'s ,numbers (formatted as texts), texts and most importantly formulas.
Can someone please help with a VBA macro to:
Find anything that looks like number and convert it to number
Ignore the rest
Don't convert formulas to values
Thank you very much
You can do this without code, or with quicker code avoiding loops
Manual
Copy a blank cell
Select your range B6:T100001
Press F5. Then Goto ... Special
check Constants and then Text
Paste Special Multiply and check Add
This converts text only cells with numbers into numbers, and leaves actual text or formulae alone
Code
Sub Update()
Dim rng1 As Range
On Error Resume Next
Set rng1 = Range("B6:T10000").SpecialCells(xlCellTypeConstants, 2)
On Error Resume Next
If rng1 Is Nothing Then Exit Sub
'presumes last cell in sheet is blank
Cells(Rows.Count, Columns.Count).Copy
rng1.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd
End Sub
here's my version:
Sub Test()
Dim rng as Range, cel as Range
Set rng = Thisworkbook.Sheets("Sheet1").Range("B6:T10000")
For Each cel In rng
If Not IsError(cel.Value) Then _
If Len(cel.Value) <> 0 And cel.HasFormula = False And _
IsNumeric(cel.Value) Then cel.Value = Val(cel.Value)
Next cel
End Sub
I've tested it, and works fine.
Hope this helps.
Give this a try:
Sub Converter()
Dim rBig As Range, r As Range, v As Variant
Set rBig = Range("B6:T10000")
For Each r In rBig
v = r.Value
If v <> "" And r.HasFormula = False Then
If IsNumeric(v) Then
r.Clear
r.Value = v
End If
End If
Next r
End Sub
EDIT#1:
This version ignores errors:
Sub Converter()
Dim rBig As Range, r As Range, v As Variant
Set rBig = Range("B6:T10000")
For Each r In rBig
v = r.Value
If Not IsError(v) Then
If v <> "" And r.HasFormula = False Then
If IsNumeric(v) Then
r.Clear
r.Value = v
End If
End If
End If
Next r
End Sub
ActiveSheet.Range("b5:b6004,h5:h6004").Select
For Each xCell In Selection
If IsNumeric(xCell) = False Then
xCell.Value = Val(xCell.Value)
Else
End If
Next xCell