I have a table in range A5 to A100 I need to know if it is possible how to do it, for example I empty cell A44, cells from A45 onwards scale to fill up cell A44 that I have emptied, thanks
Sub DeleteThem()
Dim i As Integer
Dim LastRowF As Long
With ActiveSheet
LastRowF = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For i = 1 To LastRowF
If Range("A" & i).Value = "" Then
Range("A" & i).Delete Shift:=xlUp
End If
Next i
End Sub
Related
I tried using the code below but it display the entire row in the new sheet. Is there a way that i can move only specific columns to the new sheet by modifying the vba macro code below?
Thanks in advance!
Sub CopyExpired()
Dim bottomB As Integer
bottomB = Sheets("sheet1").Range("B" & Rows.Count).End(xlUp).Row
Dim c As Range
For Each c In Sheets("sheet1").Range("B1:B" & bottomB)
If c.Value = "expired" Then
c.EntireRow.Copy Worksheets("sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next c
End Sub
Try to use an .AutoFilter.
Sub CopyExpired()
With Worksheets("sheet1")
If .AutoFilterMode Then .AutoFilterMode = False
With .Cells(1, "A").CurrentRegion
.AutoFilter field:=2, Criteria1:="expired"
With .Resize(.Rows.Count - 1, 1).Offset(1, 0)
If CBool(Application.Subtotal(103, .Cells)) Then
.SpecialCells(xlCellTypeVisible).Copy _
Destination:=Worksheets("sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
End With
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
End Sub
Replace
c.EntireRow.Copy
with
Range("C" & c.Row & ",E" & c.Row & ",H" & c.Row).Copy
and you can select what columns to use
if I didnt do the syntax 100% right then sorry. Dont have excel near me.
1st: please dont use A1 codes in your macros. Rather use the R1C1 method as follows:
dim sh as worksheet
set sh =activeworkbook.activesheet
sh.cells(1,2) = "Test worked!!"
'this will put the text into row 1 column 2 of your sheet.
2nd: you could copy each cell via a subroutine.
for example:
dim rw1 as integer, lastRw as integer, cellsToRight as integer
lastRw = sh.UsedRange.SpecialCells(xlCellTypeLastCell).Row
for rw1 = 1 to lrw
for col=1 to 10
sh.cells(rw1,col + cellstoright)=sh.cells(rw1,col)
next col
next rw1
or you could just do the colums yourself manualls, eg... array of integer with the values 1,3,4,6,7,8 ... and then loop over the array with your integers as columns, same thing as the above loops.
' I am trying to have Excel recognize a blank cell and fill in with value from
above cell.
Dim cell As Range
Dim lastrow As Long
lastrow = .Cells(1048576, 1).End(xlUp).Row - 1
For Each cell In Range("i2:j" & lastrow)
If IsEmpty(cell.Value) Then
cell.FormulaR1C1 = "=R[-1]C"
Exit For
End If
Next cell
Try this...
Sub FillBlanks()
Dim lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
On Error Resume Next
Range("I2:J" & lr).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
End Sub
I am trying to search for text on a sheet in column c then if found within the same row select column a and copy and paste to sheet two. i have started with this code
Sub Test()
For Each Cell In Sheets("Asset Capture").Range("C35:C3000")
If Cell.Value = "MONITOR" Then
matchRow = Cell.Row
Rows.Range(matchRow & ":" & matchRow).Select
Selection.Copy
Sheets("GRN Status Report").Select
lastRow = ActiveSheet.UsedRange.Rows.Count
If lastRow > 1 Then lastRow = lastRow + 1
ActiveSheet.Range("A" & lastRow).Select
ActiveSheet.Paste
Sheets("Asset Capture").Select
End If
Next
End Sub
but it is selecting the whole row and i can not figure out how to change the code to select data from just the A column?
Try this:
Sub Test()
Dim Cell As Range, rngDest As Range
Set rngDest = Sheets("Grn Status Report").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
For Each Cell In Sheets("Asset Capture").Range("C35:C3000")
If Cell.Value = "MONITOR" Then
Cell.EntireRow.Cells(1).Copy rngDest
Set rngDest = rngDest.Offset(1, 0)
End If
Next
End Sub
Note you don't need to use Select/Activate, and your code will be more robust if you avoid it as much as possible.
See: How to avoid using Select in Excel VBA macros
Hope you looking for this
Sub Test()
increment = Worksheets("GRN Status Report").Range("A" & Rows.Count).End(xlUp).Row
For Each cell In Sheets("Asset Capture").Range("C5:C3000")
If cell.Value = "MONITOR" Then
matchrow = cell.Row
matchcontent = Range("A" & matchrow).Value
Worksheets("GRN Status Report").Cells(increment, 1) = matchcontent
increment = increment + 1
End If
Next
End Sub
I wanted to copy the highlighted cells from one table to another in the same sheet, but the code that I use always skip the cell before the last cell, How can I edit the code in order to copy all the highlighted cells, and when I run the macro again it just update the second table ?
here is the code:
Sub CopyCat()
ActiveSheet.Unprotect Password:="P#ssw0rd"
Dim LR As Long, i As Long, j As Long
Dim c As Range
j = 1
LR = Range("A" & Rows.Count).End(xlUp).Row
For Each c In Worksheets("MB").Range("A15:I60" & LR)
If c.Interior.ColorIndex = 3 Then
c.Copy Destination:=Worksheets("MB").Range("J" & j)
j = j + 1
End If
Next c
ActiveSheet.Protect Password:="P#ssw0rd"
End Sub
Please help !!
Try this:
Sub CopyCat()
With Sheets("Sheet1")
'Unprotect sheet
.Unprotect Password:="P#ssw0rd"
Dim lastRow, row As Long
Dim cell As Range
row = 1
'get last row should start from A15 because i think your table is start at A15.
lastRow = .Range("A15").SpecialCells(xlCellTypeLastCell).row
'loop all cell from desired range of "fromsheetname" sheet
For Each cell In .Range("A15:G" & lastRow)
If cell.Interior.ColorIndex = 3 Then
cell.Copy Destination:=.Range("J" & row)
row = row + 1
End If
Next cell
'Protect sheet
.Protect Password:="P#ssw0rd"
End With
End Sub
I'm trying to delete an entire row in excel if column B and C are blank for that row. I have this vba code that deletes an entire row if the whole row is blank. How can I only delete the row if B and C have no value?
Thank you
Sub DeleteBlank()
Dim rng
Dim Lastrow As Integer
Set rng = Nothing
Lastrow = Range("A" & Rows.Count).End(xlUp).Row
For Each i In Range("B1:B" & Lastrow)
If Application.CountA(i.EntireRow) = 0 Then
If rng Is Nothing Then
Set rng = i
Else
Set rng = Union(rng, i)
End If
End If
Next i
MsgBox (Lastrow)
If Not rng Is Nothing Then
rng.EntireRow.Delete
End If
End Sub
--Update--
The problem is solved. Thanks to izzymo and sous2817
Here is the current code
Sub DeleteBlank()
Dim i As Integer
Dim Lastrow As Integer
Lastrow = Range("A" & Rows.Count).End(xlUp).Row
MsgBox (Lastrow)
For i = Lastrow To 2 Step -1
If Trim(Range("B" & i).Value) = "" And Trim(Range("C" & i).Value) = "" Then
Range("B" & i).EntireRow.Select
Selection.Delete
End If
Next i
MsgBox "Done"
End Sub
As asked for, here is a way to do it without looping:
Sub NoLoopDelete()
Dim lr As Long
lr = Range("A" & Rows.Count).End(xlUp).Row
With Sheet1.Range("A1:I" & lr)
.AutoFilter
.AutoFilter Field:=2, Criteria1:="="
.AutoFilter Field:=3, Criteria1:="="
.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter
End With
End Sub
The results should be the same, but this way should be faster, especially if you have a lot of rows. Obviously, change the column reference to suit your layout and feel free to fancy it up w/ some error checking,etc.
Try this
Sub DeleteBlank()
Dim i as Integer
Dim Lastrow As Integer
Lastrow = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To Lastrow
If Trim(Range("B" & i).Value) = "" And Trim(Range("CB" & i).Value) = "" Then
Range("B" & i).EntireRow.Select
Selection.Delete
i = i - 1
End If
Next i
MsgBox "Done"
End Sub