I have a table where sometimes there is data missing in the Column G (7th).
So far I selected a range in this column with my mouse and then ran this macro to fill empty cells with "No Data":
Sub FillEmptyCell()
Dim cell As Range
Dim InputValue As String
For Each cell In Selection
If IsEmpty(cell) Then
cell.Value = "No Data"
End If
Next
End Sub
However data in that column keeps getting more and I would like to automatically select the entire table range of the 7th column and fill empty cells with "No Data".
How do I implement this?
Try this
Dim lr As Long
lr = Cells(Rows.Count, 7).End(xlUp).Row
Dim Rng As Range
Set Rng = Range("G1:G" & lr)
For Each cell In Rng
If IsEmpty(cell) Then
cell.Value = "No Data"
End If
Next
Related
I want to convert to upper case a selected range in Excel.
Here's my code
Dim rng As Range
Set rng = Selection
rng.Value = rng.Parent.Evaluate("INDEX(UPPER(" & rng.Address & "),)")
It works on a large range, but gives the #VALUE! error when only a single cell is selected.
Cut your selection down to the used range in case you have selected an entire column or row.
Process a single cell if you only have a single cell selected; process in bulk for any multiple cell selections.
Dim rng As Range
Set rng = Intersect(Selection, Selection.Parent.UsedRange)
If rng.Cells.Count > 1 Then
rng.Value = Application.Evaluate("INDEX(UPPER(" & rng.Address & "),)")
Else
rng = UCase(rng.Value)
End If
This code will work for single cell or a selection:
Sub ChangeCellCase()
Dim CellCase
For Each CellCase In Selection
CellCase.Value = UCase(CellCase.Value)
Next
End Sub
I just want to know how to loop through the non blank cells on Column A. What I'm trying to do is copy the contents on [A1:B1] to be added on top of each non blank cells on Column A. So far I have counted the non blank cells on column A but I'm stuck. I know that an Offset function should be used for this.
Here's my code so far:
Dim NonBlank as Long
NonBlank = WorksheetFunction.CountA(Worksheet(1).[A:A])
For i = 1 to NonBlank
[A1:B1].Copy Offset(1,0). "I'm stuck here"
Next i
If you are trying to fill the headers for each Product, try this...
Sub FillHeaders()
Dim lr As Long
Dim Rng As Range
lr = ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
On Error Resume Next
Range("A1:B1").Copy
For Each Rng In Range("A3:A" & lr).SpecialCells(xlCellTypeConstants, 2).Areas
If Rng.Cells(1).Value <> Range("A1").Value Then
Rng.Cells(1).Offset(-1, 0).PasteSpecial xlPasteAll
End If
Next Rng
Application.CutCopyMode = 0
Application.ScreenUpdating = True
End Sub
As example to simulate the effect of Ctrl-Down from Cell A1 and display the Address, Value in the Immediate Window:
Sub HopToNextNonBlankCellBelow()
Dim oRng As Range
Set oRng = Range("A1")
Debug.Print "Cell Address", "Cell Value"
Do
Set oRng = oRng.End(xlDown)
If Not IsEmpty(oRng) Then Debug.Print oRng.Address(0, 0), oRng.Value
Loop Until oRng.Row = Rows.Count
Set oRng = Nothing
End Sub
Try this... I've (probably) overcounted the rows at 1000, but it likely won't make a difference with your performance. If you wanted to be more precise, there are hundreds of articles on how to find the last row of a range. As for the Offset function, it references a cell in relation to the one we're looping through. In the example below, the code is saying cell.offset(0,1) which means one cell to the right of the cell we are currently looping through. A clearer (less loopy!) example would be if you typed: Range("A10").offset(0,1) it would be the same as typing Range("B10")
Dim Cell As Range
For Each Cell In Range("A2:A1000").Cells
If Not IsEmpty(Cell) Then
Cell.Offset(0, 1).Value = Cell.Value
End If
Next Cell
Rng1.Copy Destination:=Worksheets("RefindData").Range(Destination)
Where Rng1 is the range of data to be copied and Destination is currently a cell reference (E.g B2)
This code will be called multiple times. How can I alter this so that the destination is the same column (E.g column B) but the row is the next empty cell?
E.g so on the first call, B2 onwards is where the values are copied to, then on the next call the next empty cell after the first call is where the second call should start outputting its values. Then the next empty cell for the start of the third call, and so on.
I can alter the Destination variable to just state column letter if something like this:
Rng1.Copy Destination:=Worksheets("RefindData").Range(Destination & ???)
Is along the right lines?
Sub CopyPasteCells()
Dim Rng1 As Range, Rng2 As Range, ws As Worksheet
Set ws = Worksheets("RefindData")
Set Rng1 = ws.Range("C2:C10") 'Copy range as you like
Set Rng2 = ws.Range("B" & ws.Rows.Count).End(xlUp).Offset(1, 0) 'Paste range starting from B2 and then first empty cell
Rng1.Copy Destination:=Rng2 'Copy/Paste
End Sub
You can also try something like code below.
Assumptions:
Active cell is in the column, where you want to paste the results (you want to paste results in column B -> select cell from B column [for example B2],
The first row is filled with headers, so the results gonna be pasted from second row
Code
Sub CutCopyPaste()
Dim lngCol As Long
Dim rngCopy As Range
Set rngCopy = Range("A1") 'The cell which ic copied
lngCol = Selection.Column 'active column where the results will be pasted
On Error Resume Next
rngCopy.Copy Cells(Cells(1, lngCol).End(xlDown).Row + 1, lngCol)
If Err.Number = 1004 Then
MsgBox "Be sure that active cell is in the column, where the results should be pasted!" & vbNewLine & vbNewLine & "Try again"
Err.Clear
End If
End Sub
You mean like this?
Sub Sample()
Dim rng1 As Range
Dim wsO As Worksheet
Set wsO = Worksheets("RefindData")
Set rng1 = Range("A1:A10")
rng1.Copy Destination:=wsO.Range("B" & _
wsO.Range("B" & wsO.Rows.Count).End(xlUp).Row + 1)
End Sub
Every time you run the macro it will paste in the next available row after the last row.
I have section title cells set at 10 pt font while all other data is set at 9 point font in column A. I am trying to write a vba macro to loop through column A to move each title cell down one row(because the csv leaves a blank cell below them) then move on to the next title cell in the column. Here is my attempt but I'm not sure what I'm doing wrong here.
Sub FontSpacing()
Dim Fnt As Range
For Each Fnt In Range("A8:A5000")
If Fnt.Font.Size = "10" Then
ActiveCell.Cut Destination:=ActiveCell.Offset(",1")
End If
Next
Try this
Sub FontSpacing()
Dim r As Range
For Each r In ThisWorkbook.Worksheets("Sheet1").Range("A8:A5000")
If r.Font.Size = 10 Then
r.Offset(1,0).Value = r.Value
r.Value = vbNullString
End If
Next r
End Sub
The issues:
Offset(",1") shouldn't have the speech marks. I.e. it should be Offset(0,1). In fact, if you want to paste to the row below, then it should be Offset(1,0).
Avoid using ActiveCell. It's not the cell that is looping through your range, it's just the cell that was active on the worksheet when you ran the sub.
Fnt is a bad name for a range, it's probably the reason you got confused. When declaring (dimensioning) a range, try to give it a name that makes it clear you're working with a range.
Extra:
Fully qualify your range reference to avoid an implicit reference to the ActiveSheet e.g. ThisWorkbook.Worksheets("Sheet1").Range("A1").
Avoid cutting an pasting by setting the Value directly
Your indentation is out, which makes it look like a complete Sub, but it's missing the End Sub.
Not sure if you meant 1 Row below or 1 Column right so:
To shift 1 Column:
Sub FontSpacing()
Dim rng As Range, cell As Range
Set rng = Range("A1:A5000")
For Each cell In rng
If cell.Font.Size = "10" Then
cell.Offset(0, 1).Value = cell.Value
cell.Clear
End If
Next
End Sub
To shift 1 Row:
Sub FontSpacing()
Dim rng As Range, cell As Range
Set rng = Range("A1:A5000")
For Each cell In rng
If cell.Font.Size = "10" Then
a = cell.Row + 1
Rows(a & ":" & a).Insert Shift:=xlDown, CopyOrigin:=1
cell.Offset(1, 0).Value = cell.Value
cell.Offset(1, 0).Font.Size = "11"
cell.Clear
End If
Next
End Sub
Hi Can I ask for a sample macro code to compare 2 different columns from 2 different sheets.
Here's the columnA in sheet1
Here's the column A in sheet2
Here's what I need to make as an output in sheet1
Then all cells in column A sheet1 without match such as red in the picture above should be cut and copied in column C in sheet1 like the below
lastly all cells in column A sheet 2 that has no match should be cut as well and pasted in column D in sheet 1 such as ABC:PINK, ABC:VIOLET and ABC:BLACK as shown below
Thanks for the help in advance.
Here's what I got so far
Sub Button1_Click()
On Error GoTo ErrorHndler:
Dim myRange As Range
Dim sRng As Range
Set myRange = Range("A1:A50")
Start:
For Each sRng In myRange
If sRng Like Sheets("Sheet2").Range("A1").Value Then
MsgBox (Sheets("Sheet2").Range("A1").Value) <----it does not pass here
(----I have no Idea what to put here-----)
'GoTo NextCell
Else
'GoTo Start
MsgBox (Sheets("Sheet2").Range("A1").Value)
'MsgBox "Doesn't match" <-----for debugging purposes
End If
NextCell:
Next sRng
ErrorHandler:
MsgBox ""
End Sub
You can search a range for a value using Range.Find
Range.Find returns Nothing if no match is found or a Range if a match is found.
You can check if two objects refer to the same object using the is operator.
Here is an example:
Sub lookup()
Dim TotalRows As Long
Dim rng As Range
Dim i As Long
'Copy lookup values from sheet1 to sheet3
Sheets("Sheet1").Select
TotalRows = ActiveSheet.UsedRange.Rows.Count
Range("A1:A" & TotalRows).Copy Destination:=Sheets("Sheet3").Range("A1")
'Go to the destination sheet
Sheets("Sheet3").Select
For i = 1 To TotalRows
'Search for the value on sheet2
Set rng = Sheets("Sheet2").UsedRange.Find(Cells(i, 1).Value)
'If it is found put its value on the destination sheet
If Not rng Is Nothing Then
Cells(i, 2).Value = rng.Value
End If
Next
End Sub