I have an excel file which includes a lot of rows. Every second rows are slipped. How can I fix these slipped rows by VBA?
I have attached a little template:
And what can I do if the blank cells are there on the right side?
Here is the VBA version of my comment with shift to left:
Range("A:A").SpecialCells(xlCellTypeBlanks).Delete xlShiftToLeft
There is no shift to right delete, but there are few ways around it depending on the layout. A more general approach can be to move the blank cells selection to the left and use insert shift to right, but I am not sure how to do that without VBA.
For example, selecting the blank cells in column F and inserting the corresponding cells on the same rows in column A:
Intersect(Range("A:A"), Range("F:F").SpecialCells(xlCellTypeBlanks).EntireRow).Insert xlShiftToRight
A more general approach for more random blank areas is to shift each row separately:
With ActiveCell.Worksheet.UsedRange ' or change to a different range
.SpecialCells(xlCellTypeBlanks).Delete xlShiftToLeft ' to shift all non-blank cells to the left
For Each area In .SpecialCells(xlCellTypeBlanks).Areas
area.Offset(, .Column - area.Column).Insert Shift:=xlToRight
Next
End With
Assumes data in columns A to F
Sub Main()
Dim rng As Range, cl As Range
Set rng = Range("B1:B" & Range("B1").End(xlDown).Row)
For Each cl In rng
If cl.Offset(0, -1) = vbNullString Then
Range(Cells(cl.Row, cl.Column), Cells(cl.Row, 6)).Cut Destination:=cl.Offset(0, -1)
End If
Next cl
End Sub
try this:
Sub slipp_fix()
Set ww = Application.Selection
Set ww = Application.InputBox("Select first col of table", xTitleId, ww.Address, Type:=8)
For Each C In ww
If C.Value = "" Then
C.Select
Selection.Delete Shift:=xlToLeft
End If
Next
end sub
Related
to organize my projects, I created an excel sheet, which is basically a calendar, but the dates are not fixed and differ from project to project. Certain dates should be colored in different ways. Thus far I used conditional formatting to achieve this, but I find CF to not always work as I want it to. Besides, since I do a lot of copy & pasting, the CF rules add up enourmously over time, slowing down the worksheet. VBA might also be more flexible in the end.
I started with coloring the cell containing today's date, using the following code (I am a VBA/Coding beginner; the code is from another website, I just modified it to suit my demands).
Option Explicit
Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim Dates As Range
Set Dates = Range("B2:H2," & _
"B6:H6")
For Each cell In Dates
If Not IsDate(cell.Value) Then
End If
If IsEmpty(cell.Value) Then
End If
If cell.Value = Date Then
cell.Interior.ColorIndex = 3
'Include more conditions e.g. lookup date in list of holidays; if date = holiday then different color
ElseIf cell.Value - Date <> 0 Then
cell.Interior.ColorIndex = 0
End If
Next cell
End Sub
Now I'd also like the macro to compare the dates in the range.1 "Dates" with a list of other dates (range.2) (e.g. holidays). If a cell from "Dates" matches with a cell from range.2, the cell that matches is supposed to get another color.
This was no problem with CF but here I am really at a loss.
I tried to do it manually by adding
ElseIf cell.Value = cell(1, 1).Value Then
cell.Interior.ColorIndex = 2
However, this colors all cells, not only the cell that matches with the date in cell(1, 1).
Any help is greatly appreciated.
Kind regards
Dennis
This is an example; the code checks values in ColA to values in ColB, and if a match is found, colors the cell in ColA, Change the references as desired.
Dim xcel As Range
Dim ycel As Range
With Worksheets("Sheet1")
For Each xcel In .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
For Each ycel In .Range("B1", .Cells(.Rows.Count, "B").End(xlUp))
If xcel.Value = ycel.Value Then
xcel.Interior.Color = RGB(255, 255, 0)
End If
Next ycel
Next xcel
End With
If you define range1 and range2 appropriately, the following will do the trick:
Sub colorCells()
Set range1 = Range("B1:B5")
Set range2 = Range("F1:F15")
For Each cel In range2
Set found = range1.Find(cel.Value, LookIn:=xlValues)
If found Is Nothing Then
cel.Interior.ColorIndex = 0
Else
cel.Interior.ColorIndex = 3
End If
Next cel
End Sub
I want to search through cells in Row 2 of worksheet "In Motion". If a cell is highlighted yellow, I want to copy the entire column and paste it to worksheet "Dashboard". I want this to repeat to find every yellow cell in row 2 of "In Motion". I also want the columns to paste sequentially onto "Dashboard".
The code I have, which I've built partly from running macros doesn't work. It DOES copy the column of the first yellow cell it finds on "In Motion" and pastes to A1 of "Dashboard". But, it DOES NOT loop through all the cells in row 2. It just stops.
Also, I think if the loop were working, my code wouldn't effectively paste columns sequentially to "Dashboard". I think they'd all be pasting to A1.
Sorry for the noob quesiton. Help is greatly appreciated!
Sub AutoPopulateNew()
Dim C As Range
'Clear Dashboard
Worksheets("Dashboard").Activate
Worksheets("DashBoard").Cells.ClearContents
'Move to In Motion Sheet
Worksheets("In Motion").Activate
'Find and copy yellow highlighted cells
For Each C In Worksheets("In Motion").Rows("2:2")
C.Select
With Application.FindFormat.Interior.Color = 65535
End With
Selection.Find(What:="", LookIn:=xlFormulas, LookAt _
:=xlPart, SearchFormat:=True).Activate
ActiveCell.EntireColumn.Copy _
Destination:=Worksheets("Dashboard").Range("A1")
Next C
Worksheets("Dashboard").Activate
End Sub
You don't need to activate a sheet to write in it. I like to use RGB declaration of colors and(255,255,0) is yellow. You can use vbYellow instead too. To find out the RGB numbe of any color, select the cell, goto the buckets icon that colors the background, choose more colors and then custom to see the RGB numbers. This code will do that, edit as you need.
Sub AutoPopulateNew()
Dim i As Integer
Dim j As Integer
Dim count As Integer
Dim c As Range
'Clear Dashboard sheet
Worksheets("DashBoard").Cells.ClearContents
count = 1 'counts the cells with a matching background color
'Loop through the cells and check if the background color matches
For Each cell In Worksheets("In Motion").Rows(2).Cells
If cell.Interior.Color = RGB(255, 255, 0) Then
Worksheets("Dashboard").Cells(1, count).Value = cell.Value
count = count + 1
End If
Next cell
End Sub
Thanks Ibo for the help! The loop worked going through the highlighted cells.
For what it's worth, I ended up changing my approach to copying and pasting columns based on whether they are marked with "x" in a given row. Code is below if it helps anyone who stumbles here.
Sub AutoPopulateX()
Dim SingleCell As Range
Dim ListofCells As Range
Dim i As Integer
'Clear Dashboard
Worksheets("Dashboard").Activate
Worksheets("DashBoard").Cells.ClearContents
'Move to In Motion and Set Range
Worksheets("In Motion").Activate
Application.Goto Range("a1")
Set ListofCells = Worksheets("In Motion").Range("a2:ba2").Cells
i = 1
Set SingleCell = Worksheets("In Motion").Cells(2, i)
'Loop: search for xyz and copy paste to Dashboard
For Each SingleCell In ListofCells
If InStr(1, SingleCell, "x", 1) > 0 Then
Range(Cells(3, i), Cells(Rows.count, i)).Copy
Worksheets("Dashboard").Paste Destination:=Worksheets("Dashboard").Cells(1, Columns.count).End(xlToLeft).Offset(0, 1)
End If
Application.Goto Range("a1")
i = i + 1
Next SingleCell
'Clean up Dashboard
Worksheets("Dashboard").Columns("a").Delete
Worksheets("Dashboard").Activate
End Sub
Been awhile since I've done some programming and I'm not having much luck with a simple excel vba macro. I have data in a column and i need to select then delete the cells that do not contain a particular value. My data looks like this in a column:
990ppbAu/1,2
990ppbAu/0,5
990ppbAu/0,5
990ppbAu/0,3
9900ppmZr/29,1
9900ppmZn/5,2
9900ppmZn/1
9900ppmZn/0,8
9900ppmZn/0,5
9900ppmCu/2,8
I need to delete the values or strings that do not contain "Au" in them. Here is the start of my code, it's not much and probably wrong...but I'm hoping someone can point me in the right direction:
Option Explicit
Sub SearchColumn()
Dim strAu As String
Dim rngFound, rngDelete As Range
strAu = "*Au*"
'Search Column
With Columns("AF")
'Find values without "Au" in string in column AF and delete.
Set rngFound = .Find(strAu, .Cells(.Cells.Count), xlValues, xlWhole)
If rngFound <> strAu
'Then select the value and delete
'Else move onto the next cell until end of the document
End With
End Sub
I should note, some cells have nothing in them, while some have a string value as seen above. I need it to go through the entire column until end of document. There are about 115,000 records in the table. Thanks in advance!
Edited3 to delete cell content only
edited 2 make it delete single cell
edited to "reverse" the previous filtering criteria and keep cells containing "Au"
if your column has header then you can use this code:
Option Explicit
Sub SearchColumnWithHeader()
Dim strAu As String
strAu = "Au"
With ActiveSheet
With .Range("AF1", .Cells(.Rows.Count, "AF").End(xlUp))
.AutoFilter Field:=1, Criteria1:="<>*" & strAu & "*"
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).ClearContents
End With
.AutoFilterMode = False
End With
End Sub
I need to search through a group of email addresses in column K and delete any rows with #noemail.com. Below is my code attempt. It was previously working but would only delete one row at a time forcing me to run the macro multiple times.
`Sub Prospects()
'
' Prospects Macro
'
' Delete rows with #noemail.com
Dim rng As Range
Dim row As Range
Dim ContainWord As String
' Select range in column K
Range("K2").Select
Range(Selection, Selection.End(xlDown)).Select
Set rng = Selection
' Set noemail as word to search for
ContainWord = "noemail"
' Loop through each cell in range, test cell contents and clear noemail.com rows
For Each row In rng.Cells
If Not row.Find(ContainWord) Is Nothing Then rng.EntireRow.Delete
Next row
Range("B2").Select
End Sub
The problem is with this line:
If Not row.Find(ContainWord) Is Nothing Then rng.EntireRow.Delete
Specifically the last part: rng.EntireRow.Delete. rng is the entire selection and not just those that are filtered. You are going cell by cell then when it finds one that returns True it deletes the top row of the rng
By changing rng to row you should get the desired effect., like this:
If Not row.Find(ContainWord) Is Nothing Then row.EntireRow.Delete
edit to deal with loop:
The problem is that when it deletes a line it moves to the next cell. If there is a "noemail" in the line right below the one that is deleted it moves that one into the row you just tested and skips it.
Try this:
Sub Prospects()
' Delete rows with #noemail.com
Dim ContainWord As String
Dim i As Integer
i = 2 ' i is a counter
' Set noemail as word to search for
ContainWord = "noemail"
' Loop through each cell in column K, test cell contents and clear noemail.com rows
Do While Range("K" & i) <> ""
If Not Range("K" & i).Find(ContainWord) Is Nothing Then
Range("K" & i).EntireRow.Delete
Else
i = i + 1
End If
Loop
Range("B2").Select
End Sub`
This will stay on the same row deleting bad addresses till it encounters a good address then move to the next.
This seems like it should be a fairly simple task but I can't seem to get it to work- I just want a simple macro that will loop through all the cells in my worksheet. If the cell is equal to zero (or blank for kicks), then just delete it, moving the other cells in the column up one.
I got nowhere trying to do it on the whole document, so I tried to do it on a single column :
Sub Macro6()
'
' Macro6 Macro
'
' Keyboard Shortcut: Ctrl+q
'
For i = 81 To 1 Step -1
If Range("A" & i) = "0" Then Range("A" & i).Delete
Next i
End Sub
I don't want to delete any rows, just the individual cells if they have value 0.
But evidently still getting nowhere.
Select the range to delete blanks within. Home > Editing – Find & Select, Go To Special, Blanks, OK, select within array, Delete…, Shift cells up, OK.
To apply the same process to cells containing 0 select range to delete 0s within and start (ie before above) by replacing these with nothing:
Home > Editing, Find & Select, enter 0 in Find what:, check Match entire cell contents and ensure Replace with: is empty, Replace All.
This small macro will delete both blanks and zeros:
Sub dural()
Dim rKill As Range, r As Range
Set rKill = Nothing
For Each r In ActiveSheet.UsedRange
If r.Value = 0 Or r.Value = "" Then
If rKill Is Nothing Then
Set rKill = r
Else
Set rKill = Union(rKill, r)
End If
End If
Next
If rKill Is Nothing Then
Else
rKill.Delete Shift:=xlUp
End If
End Sub
As pnuts pointed out, this can be a little slow. The following might be a little quicker:
Sub dural2()
With Cells
.Replace "0", ""
.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
End With
End Sub