If value found in column, copy it to certain elements in row - excel

I would like to prepare a tool which searches for anything in certain column, and if see anything, copy this value and paste this in few elements on its row
For example if in G2 there is value "ADD", then A2+B2 + E2 + F2 would be an "ADD" to (except C)
Its very hard for me to overcome obstacles, so far I came up with that.. I know this code is hard to bear with but I rarely use VBA so i never had a chance to learn so its mix of what I've found here on stackoverflow combined as per my requirements
Dim wb as Workbook
Dim ws As Worksheet
wb = ActiveWorkbook.Name
ws = Application.ActiveSheet
With ws
Set myRange = Range("G1", Range("G1").End(xlDown))
For i = 1 to myRange
if i <>"" Then
Range("A1", Range("A1").End(xlToRight)).Select
Range("A1", Range("A1").End(xlToRight)).Value = i.text
[I know this part will do from the first element of A to the last but I dont know how to choose elements I wish if they're not one next to each other]
Next i
End with

For what you want to do, it seem you don't need to declare "wb" and "ws". Vba default will use the ActiveSheet. Also wb is declared to be workbook, but ActiveWorkbook.Name is acutally an text. Your code will encounter error.
If you want to loop from G1 to its last inputted cell, you can refer to following code:
For i = 1 To Cells(Rows.Count,7).End(xlUp).Row
The rows.count refer to the last row (1048576) in excel. and "end(xlup)" will find the last cell which inputted value at G column. And the ".row" return the row number of the last cell.
Similarly, you can use "Cells(1, Columns.Count).End(xlToLeft)" to find the last column's cell inputted at row 1
You may try below code:
For i = 1 To Cells(Rows.Count, 7).End(xlUp).Row
If Cells(i, 7).Value <> "" Then
Range(Cells(i, 1), Cells(i, 2)).Value = Cells(i, 7).Value
Range(Cells(i, 4), Cells(i, Columns.Count).End(xlToLeft)).Value = Cells(i, 7).Value
End If
Next i
However, You mention you want to copy except C column. Since I dont know what actual condition that you will not copy to the column. I just simply separate the code into 2 parts, one for A and B column, another one for D to the last columns

One option could be the following:
Sub FindAndCopy()
Dim ws As Worksheet, searchRng As Range, cl As Range, searchTerm As Variant
Set ws = ThisWorkbook.ActiveSheet
With ws
Set searchRng = .Range("G1", .Range("G1").End(xlDown))
searchTerm = "ADD"
For Each cl In searchRng
If cl = searchTerm Then
Range("A" & cl.Row) = searchTerm
Range("B" & cl.Row) = searchTerm
Range("E" & cl.Row) = searchTerm
Range("F" & cl.Row) = searchTerm
End If
Next cl
End With
End Sub

Related

VBA Index Match with a loop with two conditions

I hope that someone could help me with an index match formula that is made using a loop and storing the results data on the column.
Let's say that my data is following to make it simple:
We have an employee column and a salary column. I want to find all the salary options for HR employees.
I would like to store automatically all the results found on the column J (Researched input is in column I). And I want to finish the loop after not finding any new values.
Here is the data:
My initial code is down below without a loop to go down on the range:
Sub test()
Dim oCell As Range
Dim i As Long
i = 1
Do While Worksheets("Sheet1").Cells(i, 9).Value <> ""
Set oCell = Worksheets("Sheet1").Range("A:A").Find(What:=Worksheets("Sheet1").Cells(i, 9))
If Not oCell Is Nothing Then Worksheets("Sheet1").Cells(i, 10) = oCell.Offset(0, 1)
i = i + 1
Loop
End Sub
The problem stems from two main things:
The .Find range you are searching is the entire column A, which is then set to a .Range object (oCell). However, from my VBA understanding the .Find method cannot apply the cell address of each instance of the string/search parameter you are looking for. It will only apply the cell address of the first one it finds. To set a .Range object of non-contiguous rows you could use UNION function.
The .Find(What:= ... is set to a dynamic range which moves down column I as the loop continues. This means it will never find a match because it is searching the preceding column.
Here is a suggested solution, which hopefully you can adapt to your real world data:
Option Explicit
'
Sub test()
Dim oCell As Range
Dim i As Long
i = 1
Do While Worksheets("Sheet1").Cells(i, 2).Value <> ""
' Included as a sense check when stepping through your code to confirm loop is on correct cell
'Debug.Print Cells(i, 2).Address
'Debug.Print Cells(i, 2).Value
'Debug.Print "NEXT"
Set oCell = Worksheets("Sheet1").Range("A1:A10").Find(What:="HR")
If Not oCell Is Nothing Then Worksheets("Sheet1").Cells(i, 3) = oCell.Offset(0, 1)
i = i + 1
Loop
End Sub
Try this:
Option Explicit
Sub test()
Dim i As Long
Dim wb as Excel.Workbook
Dim ws as Excel.Worksheet
i = 2 ' we don't need the header
set wb = ActiveWorkBook
set ws = wb.Sheets("Sheet1") ' or wb.Sheets(1)
Do While ws.Cells(i, 1) <> ""
If ws.Cells(i,1) = "HR" then
ws.Cells(i, 3) = ws.Cells(i,2)
End If
i = i + 1
Loop
End Sub
Tested and found working

How can I repeat code through entire data?

I have written a few lines of code that work like I want them too but I don't know how to repeat it through all rows of my data.
This probably seems like a rather simple thing but since I started VBA just a few days ago I struggle with this line of code
If I continue with ActiveCell.Offset(-1,-4) after my code it's a bug and I don't know how to repeat the code through all rows.
Sub SelectRowsWithNoBlanks()
Range("A2").Select
If ActiveCell.Offset(0, 0).Value <> "" And ActiveCell.Offset(0, 1) <> "" And ActiveCell(0, 1) <> "" And ActiveCell(0, 1) <> "" Then
Range(ActiveCell, Cells(ActiveCell.Row, ActiveCell.Column + 4)).Select
End If
End Sub
#SiddharthRout As I don't have Access to the data yet I can't tell. But I thought extending the code for more columns later on wouldn't be a problem. So in the code I have written now I was checking for the columns A-D but I thought I could easily add the "checking" for more columns if needed – Anna von Blohn 43 secs ago
In that case, here is a sample code.
Logic
As #Pᴇʜ mentioned avoid the use of .Select. Work with the objects.
Find the last row and loop through the rows. To find the last you you may want to see This
One way (which I am using) is to count the number of cells which are filled using Application.WorksheetFunction.CountA. So if it is columns A to D then there should be 4 cells to be filled to consider the "row" as filled. Similarly for Cols A to E, there should be 5 cells to be filled to consider the "row" as filled as so on.
Code
I have commented the code. So if you have a problem understanding it, let me know.
Option Explicit
Sub SelectRowsWithNoBlanks()
Dim ws As Worksheet
Dim lRow As Long, i As Long
Dim myRange As Range, rng As Range
'~~> Change this to the relevant sheet
Set ws = Sheet1
With ws
'~~> Find the last row in Col A
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Loop through the rows
For i = 2 To lRow
'~~> Change this as applicable
Set rng = .Range("A" & i & ":D" & i)
'~~> Check if the range is completely filled
If Application.WorksheetFunction.CountA(rng) = rng.Columns.Count Then
'~~> Store the range in a range object
If myRange Is Nothing Then
Set myRange = rng
Else
Set myRange = Union(myRange, rng)
End If
End If
Next i
End With
'If Not myRange Is Nothing Then Debug.Print myRange.Address
'~~> Check if any filled rows were found
If Not myRange Is Nothing Then
With myRange
'
'~~> Do what you want with the range
'
End With
Else
MsgBox "No filled rows were found"
End If
End Sub

How to count row numbers until a value is found and dynamically the count gets changed whenever the value occurs

I would like to know in vba how to count the row until a particular text "Y" is reached.
For example
I want to capture the value of the row count and use it in the for loop
For example,
For x = x-1 to ctrow
Debug.print ctrow
In the above for loop the value of ctrow should dynamically change to next row count for "Y" value once it reaches the first "Y" value. There is a "Date" field associated with the "Sample data". Once the value "Y" is matched, the date value of the "Date' field will get copied to a different workbook against same "ID" value.
It seems complicated to me. Also i found out other solution but none is working.
Also, if I need to tweak the for loop kindly let me know as well. Thanks a lot.
Sub G()
Dim rng As Range, lr, rngCopy As Range
Set rng = Range("A1").CurrentRegion
rng.Sort key1:=rng(2), Order1:=xlDescending, Header:=xlYes
lr = Columns("B:B").Find("Y", SearchDirection:=xlPrevious).Row
Set rngCopy = Range("A1:B" & lr)
'//Copy results to new sheet
With Sheets.Add(After:=Sheets(Sheets.Count))
.Cells(1).Resize(rngCopy.Rows.Count, rngCopy.Columns.Count).Value = rngCopy.Value
End With
End Sub
The code below will accomplish your full task, you must change the worksheet names, columns, and Offset to meet your specific requirements(not enough information provided). The code will first_find a "Y" value in your "Flag" column in the first worksheet. Second_it will loop through each cell in the second worksheet and compare the "ID" in the first worksheet to find a match in the second worksheet. Third_If it finds a match then it uses Offset to select the cell where you want to paste the date from the first worksheet. Then continue looping until the end. If you have problems changing the worksheet, columns, or cells references, please ask.
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
Dim lRow2 As Long
lRow2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
Set Rng1 = ws1.Range("B2", Cells(Rows.Count, Columns("A:A").Column).End(xlUp))
Dim cel As Range
For Each cel In Rng1
If cel.Value = "Y" Then
For j = 2 To lRow2
If cel.Offset(, -1).Value = ws2.Range("A" & j).Value Then
ws2.Range("A" & j).Offset(, 3).Value = cel.Offset(, 4).Value
End If
Next j
End If
Next cel

VBA code that will look for certain criteria and if it matches place data from a different column into a another one

I need help with a VBA code that will look for certain criteria and if it matches place data from a different column into a another one.
If column C says "Circum + spa" and D says "100" then the values in row F need to move over two columns to H
until column C says "Circum + spa" and D says "0" (where it will stay in column F.)
finished result will looks like a snake.
The code I have started with this process with is:
Dim l As Long
With ActiveSheet
l = .Cells(.Rows.Count, "C").End(xlUp).Row
For i = 1 To l
If .Cells(i, "C").Value2 = "CIRCUM + SPA" And
.Cells(i, "D") = "100" Then
.Cells(i + 1, "F").Value = .Cells(i + 1, "H").Value
Next
End With
But currently it just makes one row down in column F empty... I have also attempted cut/paste and an offset but all I get are error messages.
I also know that using +1 isn't going to work in final result because I need it to grab everything until the other condition is met.
I have not started on that yet, but would appreciate any advise on a Do-Until loop.
I have attached pictures of what my worksheet looks like now vs what I need it to look like after the macro runs. Also, the rows that move will not always contain 4 cells, sometimes there will be more that's why I need the do until rather than a set range.
before[1]
after (2)
Try this
Sub Demo()
Dim ws As Worksheet
Dim cel As Range, fCell As Range, lCell As Range
Dim lastRow As Long
Dim flag As Boolean
Set ws = ThisWorkbook.Sheets("Sheet4") 'change Sheet4 to your data sheet
flag = False
With ws
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row 'last row with data in Column C
For Each cel In .Range("C2:C" & lastRow) 'loop through each cell in Column C
If UCase(cel.Value) = "CIRCUM + SPA" Then 'check if Command Name is "CIRCUM + SPA"
If cel.Offset(, 1).Value = 100 Then 'check if SP is 100
Set fCell = cel.Offset(1, 0) 'set first cell to be copied in fCell
flag = True
ElseIf cel.Offset(, 1).Value = 0 Then 'check if SP is 0
If flag Then 'move ahead only if ("CIRCUM + SPA" & 100) already found
Set lCell = cel.Offset(-1, 0) 'set last cell to be copied in lCell
Set rng = .Range(fCell, lCell).Offset(, 3) 'set range using fCell and lCell
rng.Cut rng.Offset(, 2) 'move data from Column F to Column H
flag = False
End If
End If
End If
Next cel
End With
End Sub

Populate blank cells in a column until all populated from repeating list

I need to use VBA code to populate a list of filtered blank cells. I decided to make a picture with small example to explain it easier. Column D should be populated with names from col A repeating until each ID has a name.
I have absolutely no idea how to loop it to make it work - it's mind boggling! I have been searching the web for hours so I am now asking for help. Please note that column C and D are filtered with criteria blanks for column D.
Here is working code to populate blank cells of a filtered list with the same 3 names alternating.
Sub Macro1()
Dim last As Long
Dim counter As Integer
Dim nameRange As Range
Dim cell As Range
last = Range("A2").End(xlDown).Row
Set nameRange = Range("D2:D" & last).SpecialCells(xlCellTypeVisible)
counter = 1
For Each cell In nameRange
If counter = 1 Then
cell.Value = "Carrie"
counter = counter + 1
ElseIf counter = 2 Then
cell.Value = "Lisa"
counter = counter + 1
Else
cell.Value = "Bob"
counter = 1
End If
Next
End Sub
thanks for everyone's input - Hopefully, this will help someone else in the future.
This will do it without the need of filtering the data.
Sub foo()
Dim ws As Worksheet
Dim lastrowa As Long
Dim lastrowd As Long
Dim counta As Long
Dim rng As Range
counta = 2 'First row of name list in column A
Set ws = Sheets("Sheet1")
With ws
lastrowa = .Range("A" & .Rows.Count).End(xlUp).Row
lastrowd = .Range("D" & .Rows.Count).End(xlUp).Row
For Each rng In .Range(.Cells(2, 5), .Cells(lastrowd, 5))
If rng.Value = "" Then
rng.Value = .Cells(counta, 1).Value
If counta = lastrowa Then
counta = 2
Else
counta = counta + 1
End If
End If
Next rng
End With
End Sub
Range("D2:D4").Value = Range("A2:A4").Value
Range("D2:D4").AutoFill Destination:=Range("D2:D11")
If you don't know where column C ends that is easy enough to work out. Something like
Range("D2:D4").Value = Range("A2:A4").Value
Range("D2:D4").AutoFill Destination:=Range(Range("D2"), _
Range("C2").End(xlDown).Cells(1, 2))
If you don't know how far the data extends in column A:
Dim last As Integer
last = Range("A2").End(xlDown).Row
Range("D2:D" & last).Value = Range("A2:A" & last).Value
Range("D2:D" & last).AutoFill Destination:=Range(Range("D2"), _
Range("C2").End(xlDown).Cells(1, 2))
My example doesn't work perfectly, or even well... Its late :)
Create a named range that encapsulates all your "names" (called namesRange in my example).
In your "assigned" column put the following formula:
=INDEX(namesList,ROW()-((INT(ROW()/ROWS(namesList))*ROWS(namesList))),1)
Update...
Thought about it, and remembered how to excel a little more.. The following is what I was trying to do in my first example.
=INDEX(namesList,MOD(ROW()-1,ROWS(namesList)-1)+1,1)

Resources