Filling any empty cells with the value above - excel

I want to fill in all empty cells using values of above cells
state name
IL Mike
Sam
CA Kate
Bill
Leah
Should be as follows
state name
IL Mike
IL Sam
CA Kate
CA Bill
CA Leah
I tried the following
Sub split()
Dim columnValues As Range, i As Long
Set columnValues = Selection.Area
Set i = 1
For i = 1 To columnValues.Rows.Count
If (columnValues(i) = "") Then
columnValues(i) = columnValues(i - 1)
End If
Next
End Sub
I get an error when I set i. How can I modify my code

For those not requiring VBA for this, select ColumnA, Go To Special..., Blanks and:
Equals (=), Up (▲), Ctrl+Enter
should give the same result.

Given you asked for VBA, there is a quicker way than looping (the VBA equivalent of what pnuts posed above, with the additional step of removing the formula at the end):
On Error Resume Next
With Selection.SpecialCells(xlCellTypeBlanks)
.FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With

It is because i should be defined as i=1. There are although a few other problems with the code. I would change it to something like this:
Sub split()
Dim columnValues As Range, i As Long
Set columnValues = Selection
For i = 1 To columnValues.Rows.Count
If columnValues.Cells(i, 1).Value = "" Then
columnValues.Cells(i, 1).Value = columnValues.Cells(i - 1, 1).Value
End If
Next
End Sub

Sub fill_blanks()
Dim i As Long
i = 2 ' i<>1 because your first raw has headings "state " "name"
'Assume state is in your cell A and name is in your cell B
Do Until Range("B" & i) = ""
Range("B" & i).Select
If ActiveCell.FormulaR1C1 <> "" Then
Range("A" & i).Select
If ActiveCell.FormulaR1C1 = "" Then
Range("A" & i - 1).Copy
Range("A" & i).PasteSpecial Paste:=xlPasteValues
Else
i = i + 1
End If
Else
i = i + 1
End If
Loop
End Sub

For some cause the method used on post https://stackoverflow.com/a/20439428/2684623 not work for me. When the line .value=.value is executed, I get the error 'not available' (#N/D for local language) in the value of cells. Version of Office is 365.
I dont know the reason however with some modifications runs fine:
Sub TLD_FillinBlanks()
On Error Resume Next
With ActiveSheet.UsedRange.Columns(1)
If .Rows(1) = "" Then .Rows(1).Value = "'"
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
End Sub
Using loops:
Sub TLD_FillinBlanksLoop()
Dim rCell As Range
For Each rCell In ActiveSheet.UsedRange.Columns(1).Cells
If rCell.Value = "" And rCell.Row > 1 Then
rCell.FillDown
End If
Next
End Sub
I hope that can be useful for somebody. Thanks and regards.

Here is the whole module, I pasted the formulas as values at the end.
Sub FillBlanksValueAbove()
Dim sName As String
sName = ActiveSheet.Name
Dim ws As Worksheet
Dim lastRow As Long, lastCol As Long
Dim rng As Range
'Set variable ws Active Sheet name
Set ws = Sheets(sName)
With ws
'Get the last row and last column
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
'Set the range
Set rng = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))
rng.Select
'Select Blanks
rng.SpecialCells(xlCellTypeBlanks).Select
'Fill Blanks with value above
Selection.FormulaR1C1 = "=R[-1]C"
'Paste Formulas as Values
rng.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
End With
End Sub

Related

VBA If range [J:K] not empty, then copy [H:I] to the end of [J:K], else offset

I have two ranges, [H23:I32] and [J23:K50].
I need to copy values from [H23:I32] to [J23:K50] if [J23:K50] is empty, and if [J23:K50] is not empty I need to find the last row and add [H23:I32] below.
The "copy if empty" works, but the "add to the end of the list" doesn't unfortunately.
It does something, but clearly not the thing I need.
Sub Total_Loop()
Application.ScreenUpdating = False
Dim c As Range
For Each c In Range("J23:K50" & Cells(Rows.Count, "J").End(xlUp).Row)
If c.Value <> "" Then
Range("J23:K50" & Cells(Rows.Count, "J").End(xlUp).Row + 1) = Range("H23:I32")
Else: c.Value = c.Offset(, -2).Value
End If
Next
Application.ScreenUpdating = True
End Sub
Any suggestions how to fix this?
EDIT: After a lot of struggle I found a suitable solution!
Sub MoveData()
Dim lrow As Long
Dim ws As Worksheet
Set ws = Sheets("Loot")
If WorksheetFunction.CountA(ws.Range("J23:K50")) = 0 Then
ws.Range("H23:I32").Copy
ws.Range("J23").PasteSpecial xlPasteValues
Else
lrow = ws.Range("J23:K50").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
ws.Range("H23:I32").Copy
ws.Range("J" & lrow + 1).PasteSpecial xlPasteValues
End If
End Sub

How to fix 'not copying an range to new row'

I am trying to create an save button that will copy/paste the previous answer to a new row. But not just one, I want it to save up as many as you can, listing them below each other.
It is just for a school project, to make a master cheat sheet.
Private Sub Save1_Click()
Dim rA5 As Range
Set rA5 = ThisWorkbook.Sheets(1).Range("A5:E5")
Dim rA7 As Range
Set rA7 = ThisWorkbook.Sheets(1).Range("A7:E7")
If (Range("rA7").Value <> "") Then
If (Range("rA7").Offset(1).Value <> "") Then
Set rA7 = rA7.End(xlDown)
End If
Set rA7 = rA7.Offset(1)
End If
rA7.Value = rA5.Value
End Sub
It only pastes the A5:E5 to A7:E7.
It doesn't go down after that to A8:E8, A9:E9 (and so on)
Preferred outcome image
As per your comment on your own question, it looks like you want the newly calculated value on the top line, and the rest pushed down a line. If that is right, then #Error1004 answer won't work as it sticks your values on the end. The following is his code with an added reverse loop which will stick your new value on the top line and push it down:
Sub test()
Dim LastRow As Long
Dim i As Integer
With ThisWorkbook.Worksheets("Sheet1")
'Check if there is a value in A5
If .Range("A5").Value <> "" Then
'Copy range("A5:E5")
.Range("A5:E5").Copy
'If range A7 is empty
If .Range("A7").Value = "" Then
.Range("A7:E7").PasteSpecial Paste:=xlPasteValues
Else
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
i = LastRow
Do While i > 7
.Range("A" & (i + 1) & ":E" & (i + 1)).Value = .Range("A" & i & ":E" & i).Value
i = i - 1
Loop
.Range("A7:E7").Value = .Range("A5:E5").Value
End If
Else
MsgBox "There is no available data to be save."
End If
End With
End Sub
Credit to #Error1004 as I cannibalised his answer for this code.
You could try:
Option Explicit
Sub test()
Dim LastRow As Long
With ThisWorkbook.Worksheets("Sheet1")
'Check if there is a value in A5
If .Range("A5").Value <> "" Then
'Copy range("A5:E5")
.Range("A5:E5").Copy
'If range A7 is empty
If .Range("A7").Value = "" Then
.Range("A7:E7").PasteSpecial Paste:=xlPasteValues
Else
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range(.Cells(LastRow + 1, "A"), .Cells(LastRow + 1, "E")).PasteSpecial Paste:=xlPasteValues
End If
Else
MsgBox "There is no available data to be save."
End If
End With
End Sub

How to create a textjoin worksheet function with dynamic range

I have data where I have many column headers. One of the header is "Text" and one other header is "Value Date". I want to combine the values contained in every row between these columns in another column row-wise.
The problem is the number of columns between these two headers is not constant. It changes with every new ledger I export. So I want my code to be dynamic in such a way that it will identify the column of "Text" and then it will identify the column of "Value Date" and combine everything between in another column row-wise.
This is where I have reached with my code but I don't know why it's not working. I have been trying this for last 3 days only to get nowhere. When I run this code, the result which I get is "TextColumnNo:ValueColumnNo".
Sub TextJoin()
Dim TextColumnNo As Range
Dim ValueColumnNo As Range
Range("A1").Select
ActiveCell.EntireRow.Find("Text").Activate
Set TextColumnNo = Range(ActiveCell.Address(False, False))
Range("A1").Select
ActiveCell.EntireRow.Find("Value").Activate
Set ValueColumnNo = Range(ActiveCell.Address(False, False))
ActiveCell.Offset(1, -1).Select
Application.CutCopyMode = False
ActiveCell.Value = Application.WorksheetFunction.TextJoin(" ", True, _
"TextColumnNo:ValueColumnNo")
ActiveCell.Select
Selection.AutoFill Destination:=ActiveCell.Range("A1:A8524")
ActiveCell.Range("A1:A8524").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End Sub
You would need 2 loops for this. One looping through all rows and one looping through the columns to combine the text for each row.
Note that you need to adjust some things like sheet name and output column here.
Option Explicit
Public Sub TextJoin()
Dim ws As Worksheet
Set ws = Worksheets("Sheet1") 'define a worksheet
'find start
Dim FindStart As Range
Set FindStart = ws.Rows(1).Find("Text")
If FindStart Is Nothing Then
MsgBox "start not found"
Exit Sub
End If
'find end
Dim FindEnd As Range
Set FindEnd = ws.Rows(1).Find("Value Date")
If FindEnd Is Nothing Then
MsgBox "start not found"
Exit Sub
End If
'find last used row in column A
Dim lRow As Long
lRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim iRow As Long
For iRow = 2 To lRow 'loop through all rows (2 to last used row)
Dim CombinedText As String
CombinedText = vbNullString 'initialize/reset variable
Dim iCol As Long 'loop through columns for each row (from start to end column)
For iCol = FindStart.Column To FindEnd.Column
CombinedText = CombinedText & ":" & ws.Cells(iRow, iCol).Text 'combine values
Next iCol
ws.Range("Z" & iRow) = CombinedText 'write values in column Z
Next iRow
End Sub
Sub TextJoin()
Dim ColRefText As Long
Dim ColRefValueDate As Long
Const firstcol = "Text"
Const secondcol = "Value Date"
Dim r As Range
Set r = Rows(1).Cells.Find(firstcol)
If Not r Is Nothing Then
ColRefText = r.Column
Set r = Rows(1).Cells.Find(secondcol)
If Not r Is Nothing Then
ColRefValueDate = r.Column
End If
End If
If ColRefValueDate + ColRefText > 0 Then
With Cells(2, Worksheets(1).Columns.Count).End(xlToLeft).Offset(0, 1)
.Formula = Replace("=" & Cells(2, ColRefText).AddressLocal & "&" & Cells(2, ColRefValueDate).AddressLocal, "$", "")
.Copy Range(.Address, Cells(ActiveSheet.UsedRange.Rows.Count, .Column).Address)
End With
End If
End Sub

Excel - How to fill in empty lines below with current value until new value is met in the same column. Non-VBA solution needed [duplicate]

I want to fill in all empty cells using values of above cells
state name
IL Mike
Sam
CA Kate
Bill
Leah
Should be as follows
state name
IL Mike
IL Sam
CA Kate
CA Bill
CA Leah
I tried the following
Sub split()
Dim columnValues As Range, i As Long
Set columnValues = Selection.Area
Set i = 1
For i = 1 To columnValues.Rows.Count
If (columnValues(i) = "") Then
columnValues(i) = columnValues(i - 1)
End If
Next
End Sub
I get an error when I set i. How can I modify my code
For those not requiring VBA for this, select ColumnA, Go To Special..., Blanks and:
Equals (=), Up (▲), Ctrl+Enter
should give the same result.
Given you asked for VBA, there is a quicker way than looping (the VBA equivalent of what pnuts posed above, with the additional step of removing the formula at the end):
On Error Resume Next
With Selection.SpecialCells(xlCellTypeBlanks)
.FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
It is because i should be defined as i=1. There are although a few other problems with the code. I would change it to something like this:
Sub split()
Dim columnValues As Range, i As Long
Set columnValues = Selection
For i = 1 To columnValues.Rows.Count
If columnValues.Cells(i, 1).Value = "" Then
columnValues.Cells(i, 1).Value = columnValues.Cells(i - 1, 1).Value
End If
Next
End Sub
Sub fill_blanks()
Dim i As Long
i = 2 ' i<>1 because your first raw has headings "state " "name"
'Assume state is in your cell A and name is in your cell B
Do Until Range("B" & i) = ""
Range("B" & i).Select
If ActiveCell.FormulaR1C1 <> "" Then
Range("A" & i).Select
If ActiveCell.FormulaR1C1 = "" Then
Range("A" & i - 1).Copy
Range("A" & i).PasteSpecial Paste:=xlPasteValues
Else
i = i + 1
End If
Else
i = i + 1
End If
Loop
End Sub
For some cause the method used on post https://stackoverflow.com/a/20439428/2684623 not work for me. When the line .value=.value is executed, I get the error 'not available' (#N/D for local language) in the value of cells. Version of Office is 365.
I dont know the reason however with some modifications runs fine:
Sub TLD_FillinBlanks()
On Error Resume Next
With ActiveSheet.UsedRange.Columns(1)
If .Rows(1) = "" Then .Rows(1).Value = "'"
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
End Sub
Using loops:
Sub TLD_FillinBlanksLoop()
Dim rCell As Range
For Each rCell In ActiveSheet.UsedRange.Columns(1).Cells
If rCell.Value = "" And rCell.Row > 1 Then
rCell.FillDown
End If
Next
End Sub
I hope that can be useful for somebody. Thanks and regards.
Here is the whole module, I pasted the formulas as values at the end.
Sub FillBlanksValueAbove()
Dim sName As String
sName = ActiveSheet.Name
Dim ws As Worksheet
Dim lastRow As Long, lastCol As Long
Dim rng As Range
'Set variable ws Active Sheet name
Set ws = Sheets(sName)
With ws
'Get the last row and last column
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
'Set the range
Set rng = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))
rng.Select
'Select Blanks
rng.SpecialCells(xlCellTypeBlanks).Select
'Fill Blanks with value above
Selection.FormulaR1C1 = "=R[-1]C"
'Paste Formulas as Values
rng.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
End With
End Sub

Application-defined or object defined error

All,
I am receiving the error "Application defined or object defined error" for a private sub that I have written. The code is below:
Private Sub CommandButton3_Click()
Dim MyLastRow As Long
Dim i As Long
Dim cellmatch
'Find the last row
MyLastRow = Cells(Rows.Count, "A").End(xlUp).Row
'Define our comparison
cellmatch = Application.Match(Cells(i, "A").Value, Range(Cells(i, "C")).Value, 0)
'Compare Raw Data cell to Stock column and find a match
For i = 2 To MyLastRow
If IsError(cellmatch) Then
Cells(i, 2) = "Not in Stock"
Else
Cells(i, 2) = "-"
End If
Next i
End Sub
I have tried several things I found on the forums such us specifying the worksheet
Application.WorksheetFuncion.Match.....
I've also tried point to the cell or range such as:
Range(.Cells(i,"C"))....
or
.Match(.Cells(i,"A"))...
But I keep getting the same error. All of this is happening on the same sheet and I'm not trying to do anything fancy like copying. I am simply asking if a match is NOT found, then label as such, else, label it with a dash (done like this for clarity). I am sure it's something very simple but I am new to coding in VBA. Any help is much appreciated.
Thanks!
Your code requires change of this code line.
cellmatch = Application.Match(Cells(i, "A").Value, Range(Cells(i, "C")).Value, 0)
TO
'Adjust Sheetname as per your requirements instead of "Sheet1"
cellmatch = Application.Match(Cells(i, "A").Value, Worksheets("Sheet1").Columns(3), 0)
EDIT
Main problem is coming in your program because of the following code fragment.
Range(Cells(i, "C")).Value
If we refer to MSDN Documenation
Range.Cells Property (Excel)
It mentions exammples of correct syntax of usage.
Typical example is
Set r = Range("myRange")
For n = 1 To r.Rows.Count
If r.Cells(n, 1) = r.Cells(n + 1, 1) Then
MsgBox "Duplicate data in " & r.Cells(n + 1, 1).Address
End If
Next n
So it translates to Range("myRange").Cells(n,1)
and not
Range(Cells(i, "C"))
It will give correct results as shown in the snapshot.
I believe this is what you are looking for:
Option Explicit
Private Sub CommandButton3_Click()
Dim lngRow As Long
Dim rngFound As Range
Dim lngLastRow As Long
Dim shtCurrent As Worksheet
'Set the sheet to work on
Set shtCurrent = ThisWorkbook.Worksheets("Sheet1")
With shtCurrent
'Find the last row
lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Exit if the last row is 2 or smaller
If lngLastRow <= 2 Then
MsgBox "Nothing to compare!" & Chr(10) & "Aborting..."
Exit Sub
End If
'Compare Raw Data cell to Stock column and find a match
For lngRow = 2 To lngLastRow
'Only compare if there is something in column A to compare
If .Cells(lngRow, "A").Value2 <> vbNullString Then
'This is the actual MATCH / FIND
Set rngFound = .Range("C:C").Find(What:=.Cells(lngRow, "A").Value2, LookIn:=xlValues, LookAt:=xlWhole)
'Evaluate the result of the FIND = rngFound
If rngFound Is Nothing Then
.Cells(lngRow, 2).Value2 = "Not in Stock" 'not found
Else
.Cells(lngRow, 2).Value2 = "In stock in row " & rngFound.Row 'found
End If
End If
Next lngRow
End With
End Sub
Let me know if you have and problems / questions.

Resources