I am trying to pull down the date column to fill in the next sequential dates in the blank cells until the next cell down has a value in it. For example, the blank cells in the highlighted date range should read 3/23/2019 & 3/24/2019 (see screenshot, Column C):
Here is the code that I have crudely put together. But I am so new to this, I am not sure where I am going wrong. In my logic, I execute the code starting from Range C2:
Sub fillInDates()
Dim cellEndRange As Range
Dim cellStartRange As Range
Selection.End(xlDown).Select
ActiveCell.Offset(RowOffset:=-1, ColumnOffset:=0).Activate
cellEndRange = ActiveCell
Selection.End(xlUp).Select
cellStartRange = ActiveCell
cellStartRange.AutoFill Destination:=cellStartRange & cellEndRange
This can be done without VBA code.
select column C
hit F5 or Ctrl-G to open the Go To dialog
click Special
tick Blanks and hit OK
now all blank cells are selected. Without changing the selection, type a = character
hit the up arrow to reference the cell above the current cell
type +1 to add one day to the date from the cell above
hold down the Ctrl key and hit Enter.
Now that formula is in all the cells that were previously blank. You can use copy/Paste Values to replace the formula with the values it calculated.
Try, you can work with below.
Sub test()
Dim Ws As Worksheet
Dim vDB As Variant
Dim rngDB As Range
Dim myDate As Date
Dim i As Long
Set Ws = ActiveSheet
With Ws
Set rngDB = .Range("c2", .Range("c" & Rows.Count).End(xlUp))
End With
vDB = rngDB
For i = 1 To UBound(vDB, 1)
If vDB(i, 1) = "" Then
myDate = myDate + 1
vDB(i, 1) = myDate
Else
myDate = vDB(i, 1)
End If
Next i
rngDB = vDB
End Sub
Related
I am trying to write some VBA in excel that will clear all cells starting from the next empty cell in Column A (data starts from A2). For example, if A5 is blank then I want A5:P300 to all be cleared (as in all Formula and Data gone). And so on... so if A20 is blank then it deletes everything from A20:P300..
How would I go about writing this? I also need it to refer to the active workbook but a specific worksheet called ("Develop").
Thanks for any help provided.
Sub Clear()
Dim x As Worksheet
Dim rng, cell As Range
Set x = ThisWorkbook.Worksheets("R&DCosts(2)")
Set rng = x.Range("A2:A340").Cells(Rows.Count, 1).End(xlUp)
For Each cell In rng
If cell.Value = "" Then
x.Range(cell.Address & ":P350").ClearContents
End
End If
Next cell
End Sub
Try this code, please:
Sub clearRange_Bis()
Dim sh As Worksheet, firstEmpt As Long
Set sh = ThisWorkbook.Worksheets("R&DCosts(2)")
firstEmpt = sh.Range("A1").End(xlDown).Row + 1
If firstEmpt > 1000000 Then
sh.Range("A2:P300").Clear
Else
sh.Range("A" & firstEmpt & ":P300").Clear
End If
End Sub
A more simple solution
Option Explicit
Sub Clear()
Dim x As Worksheet
Dim rng, cell As Range
Set x = ThisWorkbook.Worksheets("RDCosts(2)") ' you cannot use "&"
Set rng = x.Range("A2:A340", Cells(Rows.Count, 1).End(xlUp))
For Each cell In rng
If cell.Value = "" Then
x.Range(cell.Address & ":P350").ClearContents
End
End If
Next cell
End Sub
I've written a loop that runs through a range containing month names and to trim any that are greater than three characters as I only need to see the first three ie: Jan instead of January.
The code below works in identifying the cells that contain the longer names but the LEFT function clears the cell rather than just removing the excess characters to show the first three only. Any idea what is amiss in the function? Help is much appreciated.
Many thanks.
Sub TrimMonth()
Application.ScreenUpdating = "False"
Dim rng As Range
Dim i, counter As Integer
Dim lastrow As Long
lastrow = ActiveSheet.Range("A1048576").End(xlUp).row
'Set the range to evaluate.
Set rng = Range("A2:A" & lastrow)
'initialize i to 1
i = 1
'Loop for a count of 1 to the number of rows in
'the range to evaluate.
For counter = 1 To rng.Rows.Count
'If cell i in the range contains more than 3
'characters then trim to 3 characters else increment i
If Len(rng.Cells(i)) > 3 Then
rng.Cells(i).Value = Left(Cells(i).Value, 3)
i = i + 1
Else
i = i + 1
End If
Next
Application.ScreenUpdating = "True"
End Sub
This code adds a formula to column B to return the three letter month text, then copies the values to column A before deleting the formula.
Sub TrimMonth()
Dim rDates As Range
With ThisWorkbook.Worksheets("Sheet1")
'Set reference to range containing month names.
Set rDates = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
'Add formula one column to right.
'This will convert the month name to a real date and then format it
'as three letter month text.
rDates.Offset(, 1).FormulaR1C1 = _
"=TEXT(DATEVALUE(""1-"" & RC[-1]),""mmm"")"
'Replace originals with values from formula.
rDates.Value = rDates.Offset(, 1).Value
'Clear formula.
rDates.Offset(, 1).ClearContents
End With
End Sub
Or to do it without adding the formula:
Sub TrimMonth()
Dim rDates As Range
Dim rCell As Range
With ThisWorkbook.Worksheets("Sheet1")
'Set reference to range containing month names.
Set rDates = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
'Convert each cell in range.
For Each rCell In rDates
rCell.Value = Format(CDate("1-" & rCell), "mmm")
Next rCell
End With
End Sub
Goal: Have the column header of any text in red be represented in column F of the same row as the text.
Problem: Code currently references active row, and for some reason copies F2 (which is written in red). I know the code currently would be attempting to copy/paste over a cell a few times, and I'll work that out later.
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Set rng = Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
Cells(2, ActiveCell.Column).Copy
Range("F" & (ActiveCell.row)).Select
ActiveSheet.Paste
End If
Next cell
Next row
End Sub
Not sure if I follow your logic. Your problem is that you reference active cell but you are not defining it or changing it other than through the pasting. I think you mean to reference cell (?)
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Set rng = Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
Cells(2, cell.Column).Copy Range("F" & cell.row)
End If
Next cell
Next row
End Sub
You are never changing the active cell, so the copy command is always called on row 2 of the active cell, which much be in the F column. I changed the code below to fix the issue.
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet ' this should be improved to point at the correct worksheet by name
Set rng = ws.Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
cell.Copy
ws.Range("F" & (cell.row)).PasteSpecial
End If
Next cell
Next row
End Sub
The following code is doing the following:
Starting from A1, it searches for the last filled cell and selects
the cell right after it.
After selecting the first available blank cell it selects the entire row
The entire row is then colored with color index 16.
Here you go:
Sub Macro1()
Range("A1").End(xlDown).Offset(1, 0).Select
Range(Selection, Selection.End(xlToRight)).Select
With Selection.Interior
.ColorIndex = 16
End With
End Sub
This works great but I am having difficulty selecting only columns A to H within that row. I don't want to select the entire row.
Can someone please help me? I keep getting End With errors and not sure how to fix it :S
Thank you very much for your time and consideration!
That is too much selecting! How about
Sub Macro1()
currentRow = Range("A1").end(xldown).offset(1,0).row
Range(cells(currentRow, 1), cells(currentRow,8)).Interior.ColorIndex = 16
cells(currentRow,1)= " "
End Sub
Does that work?
you can set a range for your selection, also here is another method to find last row from the end of the column (version 1) - the (Rows.Count,1) represents column A (Rows.Count,2) would represents column B and so on...
this is version one: start looking for empty row from the end of column A:
Dim rowNum As Integer
rowNum = Cells(Rows.Count, 1).End(xlUp).Row + 1
Dim rng As Range
Set rng = Range(Cells(rowNum, 1), Cells(rowNum, 8))
rng.Interior.ColorIndex = 16
this is version two: start looking for empty row from the start (row 1) of column A:
Dim rowNum As Integer
rowNum = Range("A1").End(xlDown).Offset(1, 0).Row
Dim rng As Range
Set rng = Range(Cells(rowNum, 1), Cells(rowNum, 8))
rng.Interior.ColorIndex = 16
Try this:
'Declare Variables
Dim rowNum as integer
Dim YourRange as range
'Find last row by counting cells not empty and adding 1
'Assumes that all cells from A1 down are filled. Change the +1 accordingly if not
rowNum = worksheetfunction.counta(activesheet.columns(1))+1
'Set range object to column A through H of your row number
Set YourRange = Activesheet.Range("A" & rowNum & ":H" & rowNum)
'Set interior color of the rnage object instead of using Selection
YourRange.interior.colorindex=16
I'm looking for a simple excel macro that can copy a row from one sheet to another within excel based upon having a specific number/value in the cell. I have two sheets. One called "master" and a sheet called "top10".
Here is an example of the data.
Here's the macro I'm trying to use:
Sub MyMacro()
Dim i As Long, iMatches As Long
Dim aTokens() As String: aTokens = Split("10", ",")
For Each cell In Sheets("master").Range("A:A")
If (Len(cell.Value) = 0) Then Exit For
For i = 0 To UBound(aTokens)
If InStr(1, cell.Value, aTokens(i), vbTextCompare) Then
iMatches = (iMatches + 1)
Sheets("master").Rows(cell.Row).Copy Sheets("top10").Rows(iMatches)
End If
Next
Next
End Sub
I'm sure I'm doing something extremely silly that's causing this not to work. I can run the macro itself without any error, but nothing gets copied to the sheet I'm looking to compile.
If (Len(cell.Value) = 0) Then Exit For is nonsense. Change it like below:
Sub MyMacro()
Dim i As Long, iMatches As Long
Dim aTokens() As String: aTokens = Split("10", ",")
For Each cell In Sheets("master").Range("A:A")
If Len(cell.Value) <> 0 Then
For i = 0 To UBound(aTokens)
If InStr(1, cell.Value, aTokens(i), vbTextCompare) Then
iMatches = (iMatches + 1)
Sheets("master").Rows(cell.Row).Copy Sheets("top10").Rows(iMatches)
End If
Next
End If
Next
End Sub
I believe the reason your code stops after the first row of data is because the cell your are testing in the next row is empty (in your example spreadsheet) and therefore you exit the loop (because Len(cell.Value) = 0). I would suggest a different approach: an advanced filter does exactly what you need, and is faster. In your example spreadsheet, you will need to insert an empty row 2 and put the formula "=10" in cell A2. Then the code below will do what you need (assuming thatmaster is the ActiveSheet):
Sub CopyData()
Dim rngData As Range, lastRow As Long, rngCriteria As Range
With ActiveSheet
' This finds the last used row of column A
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
' Defines the criteria range - you can amend it with more criteria,
' it will still work
' 22 is the number of the last column in your example spreadsheet
Set rngCriteria = .Range(.Cells(1, 1), .Cells(2, 22))
' row 2 has the filter criteria, but we will delete it after copying
Set rngData = .Range(.Cells(1, 1), .Cells(lastRow, 22))
' Make sure the destination sheet is clear
' You can replace sheet2 with Sheets("top10"),
' but if you change the sheet name your code will not work any more.
' Using the vba sheet name is usually more stable
Sheet2.UsedRange.ClearContents
' Here we select the rows we need based on the filter
' and copy it to the other sheet
Call rngData.AdvancedFilter(xlFilterCopy, rngCriteria, Sheet2.Cells(1, 1))
' Again, replacing Sheet2 with Sheets("top10")..
' Row 2 holds the filter criteria so must be deleted
Sheet2.Rows(2).Delete
End With
End Sub
For a reference to advanced filters, check out this link:
http://chandoo.org/wp/2012/11/27/extract-subset-of-data/
As #Ioannis mentioned, your problem is the empty cell in master A3 combined with your If (Len(cell.Value) = 0) Then Exit For
Instead of using an that if to detect the end of your range I used the following code:
LastRow= Sheets("master").Cells(Cells.Rows.Count, "A").End(xlUp).Row
Set MyRange = Sheets("master").Range("A1:A" & LastRow)
The resulting code is this:
Sub MyMacro()
Dim i As Long, iMatches As Long
Dim aTokens() As String: aTokens = Split("10", ",")
Dim LastRow
Dim MyRange
LastRow = Sheets("master").Cells(Cells.Rows.Count, "A").End(xlUp).Row
Set MyRange = Sheets("master").Range("A1:A" & LastRow)
For Each cell In MyRange
For i = 0 To UBound(aTokens)
If InStr(1, cell.Value, aTokens(i), vbTextCompare) Then
iMatches = (iMatches + 1)
Sheets("master").Rows(cell.Row).Copy Sheets("top10").Rows(iMatches)
End If
Next
Next
End Sub
I tested this with your workbook and it works perfectly. :-)