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
Related
All,
I have written the below code to check if cells in the variable range have conditional formatting. However the code falls over at "If Cells.ColorIndex = 3 Then" can anyone suggest why the error is occurring and if there is a better solution than the below code to achieve a loop through cols & rows (variable length)
Sub Check_Conditional()
Dim rng As Range
Dim row As Range
Dim cell As Range
Dim RW As Long
RW = ActiveSheet.Range("Total").Offset(rowOffset:=-1).row
Set rng = Range("O7:AB" & RW)
For Each row In rng.Rows
For Each cell In row.Cells
If Cells.ColorIndex = 3 Then
MsgBox "Not all the cells have been filled out"
Exit For
End If
Next cell
Next row
End Sub
cell.ColorIndex is not a valid Range property.
If you mean to check the font's color then use If cell.Font.ColorIndex = 3 Then
If you mean to check the Fill color, then use If cell.Interior.ColorIndex = 3 Then
When you type in the editor, Cell. the VBA autocompletes it with the following options:
There's no cell.ColorIndex in the list:
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
I have 2 sheets with more than 50K data points (Sheet 1), and a list with numbers and Alpha-Numeric texts more than 30K(Sheet 2, Column A). I want a macro code to search each cell from sheet 2 in sheet 1 and change background color of each instance.
Example:
Searching: ABC123, should find cell such as "Stack_OverflowAbc123"####".
I found some code, but so far they don't satisfy my requirement:
Sub HighlightListed()
Dim strConcatList As String
Dim cell As Range
For Each cell In Sheets("List").Range("A1:A30")
strConcatList = strConcatList & cell.Value & "|"
Next cell
For Each cell In Intersect(Sheets("Data").Range("A:A"), Sheets("Data").UsedRange) 'I assume my problem is here somewhere, its only highlights exact results.
'If i am looking for "ABC123" it should also highlight cell like "PQRABC123" or ""XYZ_ABC123"
If InStr(strConcatList, cell.Value) > 0 Then
cell.Interior.Color = RGB(255, 0, 0)
End If
Next cell
End Sub
I am fairly new to VBA, so detailed explanation will be most helpful
Try this:
Sub HighlightListed()
Dim searches As New Collection
Dim search As Variant
Dim cell As Range
For Each cell In Sheets("List").Range("A1:A30")
If cell.Value <> "" Then
searches.Add cell.Value
End If
Next cell
For Each cell In Intersect(Sheets("Data").Range("A:A"), Sheets("Data").UsedRange)
For Each search In searches
If InStr(0, cell.Value, Cstr(search), 1) > 0 Then
cell.Interior.Color = RGB(255, 0, 0)
Exit For
End If
Next search
Next cell
End Sub
I am looking to make an excel script that can find and replace data, but for the love of everything I cannot figure out how to write it.
Situation:
A-----------B-----------C
Cat-------Dog------Banana
Dog------Fish------Apple
Fish------Cat-------Orange
So the macro would look at the data in a cell in column B, then look at the adjacent cell in column C, and replace all instances of that data in column A with what if found in C. So the results would be:
A---------------B-----------C
Orange------Dog------Banana
Banana------Fish------Apple
Apple--------Cat-------Orange
But that's not all, I would like it to not change cells in A that already have been changed once! (I'm trying this with changing the background colour)
Any help? I am at a complete loss.
EDIT:
Okay I found out how to do the easy part (replacing), but I cannot find out how to not change cells that already have been changed once. Here is my code:
Sub multiFindNReplace()
Dim myList, myRange
Set myList = Sheets("sheet1").Range("A2:B3") 'two column range where find/replace pairs are
Set myRange = Sheets("sheet1").Range("D2:D5") 'range to be searched
For Each cel In myList.Columns(1).Cells
myRange.Replace what:=cel.Value, replacement:=cel.Offset(0, 1).Value, ReplaceFormat:=True
Next cel
End Sub
As far as I can tell, ReplaceFormat:=True
doesn't do anything ;/ so items that already have been replaced once still are being replaced! Is there a way to somehow make this work?
Here's the answer using your recommendation with color as a one-time limiter:
Sub Replace_Once()
'Find last row using last cell in Column B
LastRow = Range("B" & Rows.Count).End(xlUp).Row
'Clear colors in Column A
Range("A1:A" & LastRow).Interior.ColorIndex = xlNone
'Look at each cell in Column B one at a time (Cel is a variable)
For Each Cel In Range("B1:B" & LastRow)
'Compare the cell in Column B with the Value in Column A one at a time (C is a variable)
For Each C In Range("A1:A" & LastRow)
'Check if the Cell in Column A matches the Cell in Column B and sees if the color has changed.
If C.Value = Cel.Value And C.Interior.Color <> RGB(200, 200, 200) Then
'Colors the cell
C.Interior.Color = RGB(200, 200, 200)
'Updates the value in Column A with the cell to the right of the Cell in Column B
C.Value = Cel.Offset(0, 1).Value
End If
Next
Next
'Uncomment the line below to remove color again
'Range("A1:A" & LastRow).Interior.ColorIndex = xlNone
End Sub
Sub test4()
Dim LCopyToRow As Long
Dim LCopyToCol As Long
Dim arrColsToCopy
Dim c As Range, x As Integer
On Error GoTo Err_Execute
arrColsToCopy = Array(1, 25, 3) 'which columns to copy ?
Set c = Sheets("MasterList").Range("Y5") 'Start search in Row 5
LCopyToRow = 2 'Start copying data to row 2 in Sheet4
While Len(c.Value) > 0
'If value in column Y ends with "2188", copy to Sheet4
If c.Value Like "*2188" Then
LCopyToCol = 1
For x = LBound(arrColsToCopy) To UBound(arrColsToCopy)
Sheets("Sheet4").Cells(LCopyToRow, LCopyToCol).Value = _
c.EntireRow.Cells(arrColsToCopy(x)).Value
LCopyToCol = LCopyToCol + 1
Next x
LCopyToRow = LCopyToRow + 1 'next row
End If
Set c = c.Offset(1, 0)
Wend
'Position on cell A5
Range("A5").Select
MsgBox "All matching data has been copied."
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub
This is what I'm using now to pull columns and paste them in the appropriat eorder. I would like two things to happen. First, this macro simply pastes the information; I would like to insert the rows of information since i have formulas at the end of columns is the destination sheets. With just pasting, the info will paste over cells that have formulas in them. Second, the macro above doesn't carry over any borders; I have the destination sheet set up but when it pastes it loses all the borders(even though the MasterSheet and the destination sheets are bordered). Maybe inserting will fix that - I'm not sure. But at any rate I would like to insert instead of paste.
If I understand your question, I think you just need to insert a new row in your destination sheet before doing your paste.
So, in the code below I added 1 line that adds a row before the loop which pastes the columns.
If c.Value Like "*2188" Then
LCopyToCol = 1
'--> Sheets("Sheet4").Cells(LCopyToRow, LCopyToCol).EntireRow.Insert shift:=xlDown
For x = LBound(arrColsToCopy) To UBound(arrColsToCopy)
Let me know if this looks correct, or if I misunderstood you.
UPDATE
To copy formatting, as well, add these 2 lines after the line which copies the values:
c.EntireRow.Cells(arrColsToCopy(x)).Copy
Sheets("Sheet4").Cells(LCopyToRow, LCopyToCol).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone
Here's some tips for you:
This code inserts and copies format for me:
Dim rOrigin As Range, rCopyTo As Range
Set rCopyTo = Selection
Set rOrigin = Range("A2")
rCopyTo.Insert xlShiftToRight, rOrigin.Copy
Application.CutCopyMode = False
from your code, it is very clear that you are only READING values from one sheet and then writing them in another sheet. So to read values generated by formulas, use .TEXT instead of .VALUE
myValue = someRange.Text 'reads the output text by the formula but .TEXT is read only so be careful
Another thing you might do is use the Copy function that is built in.
SomeRange.Copy
then go to the sheet you want to paste and do
Activesheet.PasteValues
or
Activesheet.PasteSpecial (use options here to copy formats and so on)