I have a report that contains values in two columns (B:C), when column B has a value, column C has an empty cell for the same row.
What I want to achieve is to create a macro to search for a specific value (i.e "Desktop") in the column A and if it matches the search, copy/cut the value and paste it one cell to the next column but in the same row (that is meant to be blank), so all the values are aligned in one column (i.e "Desktop" found in A1, then paste it to B1 without creating a new column).
Example:
3 ways to get the job done.
Dim cel As Range
'This will search for "Desktop" and copy it to the cell on the right.
For Each cel In Range("B2", Range("B" & Rows.Count).End(xlUp))
If cel.Value = "Desktop" Then
cel.Offset(, 1).Value = cel.Value
'The line below will remove "Desktop" from the cell if required
'cel.ClearContents
End If
Next cel
'Or
'This will search for "Desktop", insert a cell and shift to the right.
For Each cel In Range("B2", Range("B" & Rows.Count).End(xlUp))
If cel.Value = "Desktop" Then
cel.Insert Shift:=xlToRight
End If
Next cel
'Or
'This will search for any empty cell in Col C and copy the value from Col B.
For Each cel In Range("C2", Cells(Rows.Count, 3).End(xlUp))
If cel.Value = "" Then cel.Value = cel.Offset(, -1).Value
'The line below will remove "Desktop" from the cell if required
'cel.Offset(, -1).ClearContents
Next cel
Related
So I have some "working code". Specifically, I am looking at a Range in Excel, then if I see "Yes" in a cell, coloring it Yellow and doing it for all the other cells in the range. Works GREAT.
Now I would like to sort of tweak the Fixed Range and have Excel look at the each column header and only perform this coloring based on the suffixes that I say. In this case, I would only like it to do this evaluation on the columns ending in "_ty".
Here is the code I have to color the entire range of cells:
Sub ColorCellRange()
Dim c As Range
' Loop through all cells in range A1:E + last used Row in column A
For Each c In Range("A1:E" & Range("A" & Rows.Count).End(xlUp).Row)
'Look for Yes
If InStr(1, c.Text, "Yes", vbTextCompare) > 0 Then
'Color the cell RED
c.Offset(0, 0).Interior.Color = vbYellow
End If
Next
End Sub
Current output of code
Another approach: scan the column headers and decide if to process the cells below.
Sub ColorCellRange()
Dim c As Range, hdr As Range, ws As Worksheet
Set ws = ActiveSheet 'or whatever
'loop over all headers in Row 1
For Each hdr In ws.Range("A1", ws.Cells(1, Columns.Count).End(xlToLeft)).Cells
If hdr.Value Like "*_ty" Then 'is this a header we're interested in ?
For Each c In ws.Range(hdr.Offset(1), ws.Cells(Rows.Count, hdr.Column).End(xlUp)).Cells
If InStr(1, c.Text, "Yes", vbTextCompare) > 0 Then
c.Interior.Color = vbYellow
End If
Next c
End If ' like "_ty"
Next hdr
End Sub
try this:
Option Compare Text
Sub ColorCellRange()
Dim c As Range
For Each c In Range("A1:E" & Range("A" & Rows.Count).End(xlUp).Row)
If c.Value Like "*Yes*" And Cells(1, c.Column).Value Like "*_ty" Then
c.Offset(0, 0).Interior.Color = vbYellow
End If
Next c
End Sub
or you can remove Option Compare Text and convert .value to low/upper case:
Sub ColorCellRange()
Dim c As Range
For Each c In Range("A1:E" & Range("A" & Rows.Count).End(xlUp).Row)
If LCase(c.Value) Like "*yes*" And _
LCase(Cells(1, c.Column).Value) Like "*_ty" Then
c.Offset(0, 0).Interior.Color = vbYellow
End If
Next c
End Sub
I have a script that loops through a list of ID numbers to check if there is a matching ID in another list, if there is a matching ID, it copies the email in the adjacent column and pastes it in another range. I am having trouble copying an offset range since it doesn't appear to be pasting any values. This script is not throwing any errors:
Sub tryThis()
Dim lookHere As Range, pasteHere As Range, cell As Range, searchList As Range
Set List1 = Range(Range("A1"), Range("A1").End(xlDown))
Set List2 = Range(Range("C1"), Range("C1").End(xlDown))
For Each cell In List1
Set found = List2.Find(what:=cell, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not found Is Nothing Then
cell.Offset(, 1).Resize(, 1).Copy Destination:=Cells(Rows.Count, "G").End(xlUp)
End If
Next cell
End Sub
This:
cell.Offset(, 1).Resize(, 1).Copy _
Destination:=Cells(Rows.Count, "G").End(xlUp)
will copy the value into the same cell each run, since End(xlUp) takes you to the last occupied cell in the column, not the first empty cell. You need to Offset() one down to the next empty position. Also can do this with a direct value assignment:
Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Value = cell.Offset(0, 1).Value
Edit: if the cell you want to copy is from List 2 then:
Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Value = found.Offset(0, 1).Value
I have a code that will copy and paste a whole row in worksheet called "Raw Data". If cells in Range $D$1:D have a value of "Thomas Xiong", then it will paste the whole row of everything under that value to another worksheet called "WIP".
What I am trying to do is be able to create a code that will be able to find multiple words. For example, "Thomas Xiong" and the word "Assigned" and be able to copy and paste that whole line from the worksheet "Raw Data" into another worksheet.
Also with the code I have now, it will copy and paste the whole rows but there are spaces in between each cell row in the other worksheet.
The code I have now:
Sub Test()
Dim Cell As Range
With Sheets("Raw Data")
' loop column C untill last cell with value (not entire column)
For Each Cell In .Range("D1:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
If Cell.Value = "Thomas Xiong" Then
' Copy>>Paste in 1-line (no need to use Select)
.Rows(Cell.Row).copy Destination:=Sheets("WIP").Rows(Cell.Row)
'.Range("C1:C", "A", "B", "D", "F" & Cell.Row).copy
End If
Next Cell
For Each Cell In .Range("C1:C" & .Cells(.Rows.Count, "C").End(xlUp).Row)
If Cell.Value = "Assigned" Then
' Copy>>Paste in 1-line (no need to use Select)
.Rows(Cell.Row).copy Destination:=Sheets("WIP").Rows(Cell.Row)
'.Range("C1:C", "A", "B", "D", "F" & Cell.Row).copy
End If
Next Cell
End With
End Sub
The problem is you are using the row of the cells you are copying in your destination sheet. You want to use a separate counter that you increment every time you paste something on e given row:
Sub Test()
Dim Cell As Range
Dim myRow as long
myRow = 2
With Sheets("Raw Data")
' loop column C untill last cell with value (not entire column)
For Each Cell In .Range("D1:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
If Cell.Value = "Thomas Xiong" Then
' Copy>>Paste in 1-line (no need to use Select)
.Rows(Cell.Row).copy Destination:=Sheets("WIP").Rows(myRow)
myRow = myRow + 1
End If
Next Cell
For Each Cell In .Range("C1:C" & .Cells(.Rows.Count, "C").End(xlUp).Row)
If Cell.Value = "Assigned" Then
' Copy>>Paste in 1-line (no need to use Select)
.Rows(Cell.Row).copy Destination:=Sheets("WIP").Rows(myRow)
myRow = myRow + 1
End If
Next Cell
End With
End Sub
What's not clear (to me at least) is if you want to only find rows where the value in column D is "Thomas Xiong" and the value in column C is "Assigned", in which case you want to have something like this:
Sub Test()
Dim Cell As Range
Dim myRow as long
myRow = 2
With Sheets("Raw Data")
For Each Cell In .Range("C1:C" & .Cells(.Rows.Count, "C").End(xlUp).Row)
If Cell.Value = "Assigned" and Cell.Offset(0,1).Value = "Thomas Xiong" Then
' Copy>>Paste in 1-line (no need to use Select)
.Rows(Cell.Row).copy Destination:=Sheets("WIP").Rows(myRow)
myRow = myRow + 1
End If
Next Cell
End With
End Sub
To loop through a list of names (which I will assume to be in range A1:A10 in a worksheet called "myNames") something like this should work:
Sub Test()
Dim Cell as Range
Dim NameCell as Range
Dim myRow as Long
myRow = 2
With Sheets("Raw Data")
For each NameCell in Worksheet("myNames").Range("A1:A10)
For Each Cell In .Range("C1:C" & .Cells(.Rows.Count, "C").End(xlUp).Row)
If Cell.Value = "Assigned" and Cell.Offset(0,1).Value = NameCell.Value Then
.Rows(Cell.Row).copy Destination:=Sheets("WIP").Rows(myRow)
myRow = myRow + 1
Exit For
End If
Next Cell
Next NameCell
End With
End Sub
I have a vba code that copies a file multiple times and renames the output after a list of names in column D from sheet "Linkuire".
Column D is full of concatenate formulas that bring data into cells till D1000.
When the concatenate formulas return "" (as in nothing) i want the code to ignore that cell.
' the range of cells that contain the rename list
With ActiveWorkbook.Sheets("Linkuire")
Set rRenameList = .Range("D2", .Cells(.Rows.Count, "D").End(xlUp))
End With
Now it just takes into account all D2 to D1000 cells even if some are = ""
How can I make the code ignore all cells where the return of the concatenate is "" ? (I have the same problem with a vba code that converts a certain sheet into pdf - with data got from concatenate formulas. It converts all cells even if concatenate return "" and is blank)
Thank you..
edited since pure SpecialCells() approach wouldn't work
You could use following two approaches and avoid looping:
AutoFilter() and SpecialCells() approach:
With ActiveWorkbook.Sheets("Linkuire")
With .Range("D1", .Cells(.Rows.count, "D").End(xlUp))
.AutoFilter Field:=1, Criteria1:="<>" '<--| filter out blanks
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then Set rRenameList = .Resize(.Rows.count - 1).Offset(1).SpecialCells(xlCellTypeVisible)
End With
.AutoFilterMode = False
End With
Formula and SpecialCells() approach
With ActiveWorkbook.Sheets("Linkuire")
With .Range("D2", .Cells(.Rows.count, "D").End(xlUp))
.Offset(, 1).FormulaR1C1 = "=IF(RC[-1]="""", 1,"""")"
Set rRenameList = .Offset(, 1).SpecialCells(xlCellTypeFormulas, xlNumbers).Offset(, -1)
.Offset(, 1).ClearContents
End With
End With
in this approach you're writing a formula in a "helper" column I chose to be the adjacent to the right. It can be adjusted to any other offset
This should work. It will loop through your range, and only add the cell address to your rRenameList when the length is greater than or equal to 1.
Sub Test()
' Adapted from http://stackoverflow.com/a/8320884/4650297
Dim rng1 As Range, rRenameList As Range, cel As Range
With ActiveWorkbook.Sheets("Linkuire")
Set rng1 = .Range("D2", .Cells(.Rows.Count, "D").End(xlUp))
End With
For Each cel In rng1
If Len(cel) >= 1 Then
If Not rRenameList Is Nothing Then
Set rRenameList = Union(rRenameList, cel)
Else
' the first valid cell becomes rng2
Set rRenameList = cel
End If
End If
Next cel
Debug.Print rRenameList.Address
End Sub
How do I code this in the most simplest way?
If let's say Range("A1").value = "Thursday"
Check for duplicates on all the cells which has value in them (B1, C1, D1,...)
If a duplicate is found, select 3 cells below each of those cells Range("B2:B4") and so on...
The simplest way is to check for duplicates:
Using a WorksheetFunction
=COUNTIF(A:A,A1)>1
Using the VBA
Dim Target As Range
Dim r As Range
Set Target = Range("A1", Range("A" & Rows.Count).End(xlUp))
For Each r In Target
r.Offset(0, 1) = WorksheetFunction.CountIf(Target, r.Value) > 1
Next
If you want to remove duplicates in the first column of the range
Target.RemoveDuplicates Columns:=1, Header:=xlNo
If you wanted to expand your range to include Columns B and C
Set Target = Range("A1", Range("A" & Rows.Count).End(xlUp)).Resize(, 3)
Remove duplicates in the first and third columns
Target.RemoveDuplicates Columns:=Array(1, 3), Header:=xlNo
Remove rows that contain the duplicates
Target.EntireRow.RemoveDuplicates Columns:=Array(1, 3), Header:=xlNo
Below code identifies duplicate value in a column and highlight with red. Hope this might be of some help.
iLastRow = Cells(chosenExcelSheet.Rows.Count, 1).End(xlUp).Row 'Determine the last row to look at
Set rangeLocation = Range("A1:A" & iLastRow) 'Range can be updated as per your need
'Checking if duplicate values exists in same column
For Each myCell In rangeLocation
If WorksheetFunction.CountIf(rangeLocation, myCell.Value) > 1 Then
myCell.Interior.ColorIndex = 3'Highlight with red Color
Else
myCell.Interior.ColorIndex = 2'Retain white Color
End If
Next