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
Related
I would like to delete the empty rows my ERP Quotation generates. I'm trying to go through the document (A1:Z50) and for each row where there is no data in the cells (A1-B1...Z1 = empty, A5-B5...Z5 = empty) I want to delete them.
I found this, but can't seem to configure it for me.
On Error Resume Next
Worksheet.Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
How about
sub foo()
dim r As Range, rows As Long, i As Long
Set r = ActiveSheet.Range("A1:Z50")
rows = r.rows.Count
For i = rows To 1 Step (-1)
If WorksheetFunction.CountA(r.rows(i)) = 0 Then r.rows(i).Delete
Next
End Sub
Try this
Option Explicit
Sub Sample()
Dim i As Long
Dim DelRange As Range
On Error GoTo Whoa
Application.ScreenUpdating = False
For i = 1 To 50
If Application.WorksheetFunction.CountA(Range("A" & i & ":" & "Z" & i)) = 0 Then
If DelRange Is Nothing Then
Set DelRange = Range("A" & i & ":" & "Z" & i)
Else
Set DelRange = Union(DelRange, Range("A" & i & ":" & "Z" & i))
End If
End If
Next i
If Not DelRange Is Nothing Then DelRange.Delete shift:=xlUp
LetsContinue:
Application.ScreenUpdating = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
IF you want to delete the entire row then use this code
Option Explicit
Sub Sample()
Dim i As Long
Dim DelRange As Range
On Error GoTo Whoa
Application.ScreenUpdating = False
For i = 1 To 50
If Application.WorksheetFunction.CountA(Range("A" & i & ":" & "Z" & i)) = 0 Then
If DelRange Is Nothing Then
Set DelRange = Rows(i)
Else
Set DelRange = Union(DelRange, Rows(i))
End If
End If
Next i
If Not DelRange Is Nothing Then DelRange.Delete shift:=xlUp
LetsContinue:
Application.ScreenUpdating = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
I know I am late to the party, but here is some code I wrote/use to do the job.
Sub DeleteERows()
Sheets("Sheet1").Select
Range("a2:A15000").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
for those who are intersted to remove "empty" and "blank" rows ( Ctrl + Shift + End going deep down of your worksheet ) .. here is my code.
It will find the last "real"row in each sheet and delete the remaining blank rows.
Function XLBlank()
For Each sh In ActiveWorkbook.Worksheets
sh.Activate
Cells(1, 1).Select
lRow = Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Range("A" & lRow + 1, Range("A1").SpecialCells(xlCellTypeLastCell).Address).Select
On Error Resume Next
Selection.EntireRow.SpecialCells(xlBlanks).EntireRow.Delete
Cells(1, 1).Select
Next
ActiveWorkbook.Save
ActiveWorkbook.Worksheets(1).Activate
End Function
Open VBA ( ALT + F11 ), Insert -> Module,
Copy past my code and launch it with F5.
Et voila :D
I have another one for the case when you want to delete only rows which are complete empty, but not single empty cells. It also works outside of Excel e.g. on accessing Excel by Access-VBA or VB6.
Public Sub DeleteEmptyRows(Sheet As Excel.Worksheet)
Dim Row As Range
Dim Index As Long
Dim Count As Long
If Sheet Is Nothing Then Exit Sub
' We are iterating across a collection where we delete elements on the way.
' So its safe to iterate from the end to the beginning to avoid index confusion.
For Index = Sheet.UsedRange.Rows.Count To 1 Step -1
Set Row = Sheet.UsedRange.Rows(Index)
' This construct is necessary because SpecialCells(xlCellTypeBlanks)
' always throws runtime errors if it doesn't find any empty cell.
Count = 0
On Error Resume Next
Count = Row.SpecialCells(xlCellTypeBlanks).Count
On Error GoTo 0
If Count = Row.Cells.Count Then Row.Delete xlUp
Next
End Sub
To make Alex K's answer slightly more dynamic you could use the code below:
Sub DeleteBlankRows()
Dim wks As Worksheet
Dim lngLastRow As Long, lngLastCol As Long, lngIdx As Long, _
lngColCounter As Long
Dim blnAllBlank As Boolean
Dim UserInputSheet As String
UserInputSheet = Application.InputBox("Enter the name of the sheet which you wish to remove empty rows from")
Set wks = Worksheets(UserInputSheet)
With wks
'Now that our sheet is defined, we'll find the last row and last column
lngLastRow = .Cells.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
lngLastCol = .Cells.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
'Since we need to delete rows, we start from the bottom and move up
For lngIdx = lngLastRow To 1 Step -1
'Start by setting a flag to immediately stop checking
'if a cell is NOT blank and initializing the column counter
blnAllBlank = True
lngColCounter = 2
'Check cells from left to right while the flag is True
'and the we are within the farthest-right column
While blnAllBlank And lngColCounter <= lngLastCol
'If the cell is NOT blank, trip the flag and exit the loop
If .Cells(lngIdx, lngColCounter) <> "" Then
blnAllBlank = False
Else
lngColCounter = lngColCounter + 1
End If
Wend
'Delete the row if the blnBlank variable is True
If blnAllBlank Then
.rows(lngIdx).delete
End If
Next lngIdx
End With
MsgBox "Blank rows have been deleted."
End Sub
This was sourced from this website and then slightly adapted to allow the user to choose which worksheet they want to empty rows removed from.
In order to have the On Error Resume function work you must declare the workbook and worksheet values as such
On Error Resume Next
ActiveWorkbook.Worksheets("Sheet Name").Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
I had the same issue and this eliminated all the empty rows without the need to implement a For loop.
This worked great for me (you can adjust lastrow and lastcol as needed):
Sub delete_rows_blank2()
t = 1
lastrow = ActiveSheet.UsedRange.Rows.Count
lastcol = ActiveSheet.UsedRange.Columns.Count
Do Until t = lastrow
For j = 1 To lastcol
'This only checks the first column because the "Else" statement below will skip to the next row if the first column has content.
If Cells(t, j) = "" Then
j = j + 1
If j = lastcol Then
Rows(t).Delete
t = t + 1
End If
Else
'Note that doing this row skip, may prevent user from checking other columns for blanks.
t = t + 1
End If
Next
Loop
End Sub
Here is the quickest way to Delete all blank Rows ( based on one Columns )
Dim lstRow as integet, ws as worksheet
Set ws = ThisWorkbook.Sheets("NameOfSheet")
With ws
lstRow = .Cells(Rows.Count, "B").End(xlUp).Row ' Or Rows.Count "B", "C" or "A" depends
.Range("A1:E" & lstRow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End with
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
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
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
This code works perfectly. I only have one question, I want to make it so that if there is nothing in cell Q23 that it will not put anything into NCMR Data, and say something... the code is below of what I have, and below it is what I think I need to do to a specific section to work, can someone review and make sure I am on the right path?
Option Explicit
Sub NCMR()
Dim i As Integer
With Application
.ScreenUpdating = False
End With
'Internal NCMR
Dim wsInt As Worksheet
Dim wsNDA As Worksheet
'Copy Ranges
Dim c As Variant
'Paste Ranges
Dim P As Range
'Setting Sheet
Set wsInt = Sheets("NCMR Input")
Set wsNDA = Sheets("NCMR Data")
Set P = wsInt.Range("B61:V61")
With wsInt
c = Array(.Range("B11"), .Range("B14"), .Range("B17"), .Range("B20"), .Range("Q23"), .Range("B23") _
, .Range("Q11"), .Range("Q14"), .Range("Q17"), .Range("Q20"), .Range("R26"), .Range("V23") _
, .Range("V25"), .Range("V27"), .Range("B32"), .Range("B40"), .Range("B46"), .Range("B52") _
, .Range("D58"), .Range("L58"), .Range("V58"))
End With
For i = LBound(c) To UBound(c)
P(i + 1).Value = c(i).Value
Next
With wsNDA
Dim LastRow As Long
LastRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
wsInt.Rows("61").Copy
With .Rows(LastRow)
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValues
.Interior.Pattern = xlNone
End With
With .Range("A" & LastRow)
If LastRow = 3 Then
.Value = 1
Else
.Value = Val(wsNDA.Range("A" & LastRow - 1).Value) + 1
End If
.NumberFormat = "0#######"
End With
End With
With Application
.Range("A61:V61").ClearContents
.ScreenUpdating = True
End With
End Sub
What I want to do I think:
With wsInt
Dim f As Range
Set f = .Cell("Q23")
If IsEmpty(f) Then
MsgBox "The data can't entered, you have not entered any data into the Sales Order field."
Else
c = Array(.Range("B11"), .Range("B14"), .Range("B17"), .Range("B20"), .Range("Q23"), .Range("B23") _
, .Range("Q11"), .Range("Q14"), .Range("Q17"), .Range("Q20"), .Range("R26"), .Range("V23") _
, .Range("V25"), .Range("V27"), .Range("B32"), .Range("B40"), .Range("B46"), .Range("B52") _
, .Range("D58"), .Range("L58"), .Range("V58"))
End If
End With
Maybe as simple as:
With wsInt
If Len(.Range("Q23")) = 0 Then
MsgBox "The data can't be entered, you have not entered any data into the Sales Order field."
Exit Sub
End If
End With 'added this line for clarity