Currently I have macro that looks in another document and copies an offset cell if a value is present. I already have the code below (only the part that selects/copies the offset cell), but it only will copy one row. This is fine for most of the items I am searching for. Does anyone know how to modify the code below to copy all cells that contain my searched value?
For I = LBound(MyArr) To UBound(MyArr)
Set Rng = .Find(What:=MyArr(I), _
After:=.Cells(.Cells.Count), _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
'mark the cell in the column to the right if "Ron" is found
Rng.Offset(0, 4).Select
'Rng.Copy "A" & Rcount
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
Selection.Copy (Rng)
End If
Next I
End With
What I would suggest is a loop for the .Find method.
So you have a range of data namely MyArr imagine its 50 items long. You want to look from 0 to 50 until you find your item.
Lets say you find it in positon 8. Now you do another search but this time from items 9 to 50 and see if you find a match. If you dont you know there are no more. If you do you repeat the above until you run out of elements in the array(range) or you have no more matches. Does that make sense?
Related
I'm trying to copy data from a column in a sheet called "KPI", in cells H6:H100, to a specific row in a sheet named "table". The row depends on two variables in the KPI sheet which user selects from drop downs in C2:D2.
I have managed to get the code to find the right row each time by searching columns A then B in the "data" sheet.But when it comes to the copy paste/transpose column H from "KPI" sheet into the right row on the "table" sheet it throws up a 424 error.
I might be missing something really obvious so any help is appreciated.
Sub copy_transpose()
Dim rng_source As Range
Dim Found As Range, Firstfound As String
Dim rngSearch As Range
Dim Criteria As Variant
Set rng_source = ThisWorkbook.Sheets("KPI").Range("H6:H100")
Set rngSearch = Sheets("Table").Range("A:A")
Criteria = Sheets("KPI").Range("C2:D2").Value
Set Found = rngSearch.Find(What:=Criteria(1, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Found Is Nothing Then
Firstfound = Found.Address
Do
If Found.EntireRow.Range("B2").Value = Criteria(1, 2) Then Exit Do 'Match found
Set Found = rngSearch.FindNext(After:=Found)
If Found.Address = Firstfound Then Set Found = Nothing
Loop Until Found Is Nothing
End If
If Not Found Is Nothing Then
Application.Goto Found
rng_source.Copy
Sheets("Table").Range(cell.Offset(0, 1), cell.Offset(0, 7)).PasteSpecial Transpose:=True
Else
MsgBox ("Error")
End If
End Sub
I needed more coffee. I hadn't spotted that is was referencing "cell" instead of "found".
Today I learned that "cell" is not a vba function, and was actually something I had dimensioned in my older code, and was the equivalent of "found".
I used record macro to create some code and then I put it in a loop. It works but there is an error in the find function which causes it to only work once. I tried to do something with the error but I am not having any luck having it loop. I've looked a couple of days here and there but I am at a loss. Hope you can help me. Much appreciated.
i = 1
On Error GoTo notfound
Do While Sheet1.Cells(i, 1) <> ""
Columns("J:J").Select
Selection.Find(What:="x", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Rows(ActiveCell.Row).EntireRow.Delete
notfound: msgbox "Finished"
GoTo notfound
Exit Sub
i = i + 1
Loop
I've corrected, completed, formatted and commented your code. This should take you one step closer to what you want to do.
Private Sub Sample()
Dim Crit As Variant ' the criterium to look for
Dim Fnd As Range ' the cell to find
Dim i As Long
' never create an error handler if you don't know which error to exect
' On Error GoTo notfound
i = 1
' the cell can't be "" only its value can do thjat
Do While Sheet1.Cells(i, 1).Value <> ""
Crit = "x"
' Columns("J:J").Select
' don't Select anything, address cells or ranges instead
Set Fnd = Columns("J:J").Find(What:=Crit, _
After:=ActiveCell, _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
' where is the 'Activecell'?
' a) it doesn't change while this loop is running
' but it might get deleted by this loop's action
' b) it must be in the range you are searching
' that's why your code will fail most of the time.
' don't Activate anything. Instead address the object you want to deal with.
If Fnd Is Nothing Then
MsgBox "I didn't find """ & Crit & """"
Else
Sheet1.Rows(Fnd.Row).EntireRow.Delete
End If
i = i + 1
Loop
End Sub
This code will look for "x" in column J for as long as there is a value in column A and delete the row where it is found. It's hard to imagine a relationship between the number of entries in column A and the number of "x" in column J but, hopefully, this isn't your problem. Instead, your obvious problem is the cell in which you want to start the search. It definitely isn't ActiveCell but it might be Cells(1, "J"). You can also omit this instruction and VBA will start the search after J1.
You want to LookIn formulas. If there are formulas in column J the Formula will be different from the Value. You may wish to search in xlValues.
I am trying to check whether Row 1 of my active sheet named "Exceptions" contains the text "Control Date" (two spaces) or "Control Date".
My code finds the condition false.
Dim a As Range
Dim exceptions As Worksheet
Set exceptions = ActiveWorkbook.Worksheets("Exceptions")
For Each c In Exceptions.Range("A1:Z1")
If c = "Control Date" Then
Cells.Find(What:="control date", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Else
Cells.Find(What:="Control Date", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
End If
Next c
Example of a worksheet with two spaces in "Control Date"
How to write the condition
As far as checking if the cell value is "Control Date" with a single space or one with two spaces, there are two ways of going about it:
Use the like operator
The like operator makes it easy to compare a string to a basic pattern. In this example, using the wildcard character * (Zero or more characters) will return true regardless of how many spaces are between Control and Date.
If cell.Value2 Like "Control*Date" Then
' Do something with that cell
End If
Use the or operator
Using the or operator ok to use as well, although not a flexible and perhaps a bit more difficult to see what's going on for your specific example.
If cell.Value2 = "Control Date" Or cell.Value2 = "Control Date" Then
' Do something with that cell
End If
Worksheet Codename
Each worksheet has whats called a codename. This is a reference that can be called directly in the code to that specific worksheet by it's name.
To set this name, in the properties window update the name property
So instead of
Dim Exceptions As Worksheet
Set Exceptions = ActiveWorkbook.Worksheets("Exceptions")
For Each cell In Exceptions.Range("A1:Z1")
' Do something...
Next cell
you can call the worksheet reference directly
For Each cell In Exceptions.Range("A1:Z1")
' Do something...
Next cell
Putting it together
Instead of using c for your variable, I like to make my variables easier to read and follow so I used cell.
Also, instead of hard coding your header columns in range, you could loop the cells of the entire first row. This is option suggestion though.
Lastly, be more explicit in what property you are looking for in your Cell. In my example I use .value2 to show I am looking for the value of that cell.
Public Sub Demo()
Dim cell As Range
For Each cell In Exceptions.Rows(1).Cells
If cell.Value2 Like "Control*Date" Then
' Do something with that cell
End If
Next cell
End Sub
Why duplicate the data into a third column? Whenever you need the "combined" date, just go get it, but do not store it twice.
Option Explicit '<<-- always have this
Sub doFindControl()
Dim a As Range
Dim c As Range '<<-- add this
Dim colDate As Long, colNumber As Long, colBlank As Long '<<--add this
Dim exceptions As Worksheet
Set exceptions = ActiveWorkbook.Worksheets("Exceptions")
For Each c In exceptions.Range("A1:Z1")
' first find the 2 key columns
If InStr(c, "Control") > 0 Then
If InStr(c, "Date") > 0 Then
colDate = c.Column
ElseIf InStr(c, "Number") > 0 Then
colNumber = c.Column
End If
' second look for the first blank column for you to put results in
ElseIf c.Text = "" Then
colBlank = c.Column
Exit For ' stop looking after its found
End If
Next c
' now you have the 2 FROM columns, and the TO column
MsgBox (colDate & " " & colNumber & " " & colBlank)
' and you can loop thru all the rest of the rows doing combine
End Sub
Thank you for all the answers! Robert Todar's answer led me to my lightbulb moment, and I can't believe at how simple the answer was. All I had to do was change this code:
Cells.Find(What:="Control Date", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
to:
Cells.Find(What:="Control*Date", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
I need to find the value "5005" (only this value) in column J:J, insert a new row below it, and then fill the row with values in columns A-U.
I am new to VBA and I am unable to do this without making a mess of code.
The draft would look something like this
Find all cells with value 5005 in column J:J,
Insert Row below,
Put value1 in A,
Put Value2 in B,
etc.... until column U,
Repeat on the next cell that has "5005" in it until there are no more
I am unsure what code would work best at this point and I think seeing this written out by a pro would help significantly.
In the messy code I've provided below I was able to search for the value "5005" and insert a line below it, but whatever cell I have selected in excel will be filled with the value "TRUE" and the code is quite messy. Not sure If I was going the right direction with it.
Sub AAAAAAAtest()
Dim find5005 As Range
'Have excel search 1 column instead of all cell
Set find5005 = Cells.Find(What:="5005", LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False)
If find5005 Then ActiveCell.Value = find5005.Offset(1).EntireRow.Insert
End Sub
Narrative is in the code comments
Option Explicit
Sub insert5005()
Dim rng As Range, urng As Range, faddr As String
Dim vals As Variant
'get some dummy values quickly
vals = buildAU()
With Worksheets("sheet5")
'find first 5005
Set rng = .Range("J:J").Find(What:="5005", after:=.Cells(.Rows.Count, "J"), _
LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext)
'continue if found
If Not rng Is Nothing Then
'record first found cell
faddr = rng.Address
'start loop for insert, populate and additional cells
Do
'insert new row
rng.Offset(1, 0).EntireRow.Insert
'populate row
.Cells(rng.Offset(1, 0).Row, "A").Resize(1, UBound(vals) + 1) = vals
'look for another
Set rng = .Range("J:J").FindNext(after:=rng)
'keep going until first address is reached a second time
Loop Until rng.Address = faddr
End If
End With
End Sub
Function buildAU()
'construct some dummy values
Dim i As Long, tmp As String
For i = 65 To 85
tmp = tmp & Format(i, "|v\alu\e00")
Next i
buildAU = Split(Mid(tmp, 2), Chr(124))
End Function
I have this snippet of code that I've borrowed from other post and edited(or at least tried) that I'm trying to use to subtotal some dynamic ranges. I use a key column with 0's, 1's, and 2's. I want the code to add all the coorosponding columns across from each 1 until it hits a 2 and then put the subtotal in the column with the 2. Currently, my code keeps running backwards so it is putting the wrong subtotals in. Below is a snippet of my code.
'count all 1's in each section till next 2 for subtotaling each section
With Range("P13:P" & lRow1)
Set rFind = .Find(What:=2, LookIn:=xlFormulas, SearchOrder:=xlByRows, _
Lookat:=xlWhole, SearchDirection:=xlNext, searchFormat:=False)
If Not rFind Is Nothing Then
s = rFind.Address
Do
Set r1 = rFind
Set rFind = .FindNext(rFind)
If rFind.Address = s Then
Set rFind = .Cells(.Cells.Count)
r1.Offset(, -5).Value = Application.Sum(Range(r1.Offset(-1, -5), r1.Offset(, -5)))
Exit Sub
End If
r1.Offset(, -5).Value = Application.Sum(Range(r1.Offset(-1, -5), rFind.Offset(, -5)))
Loop While rFind.Address <> s
End If
End With
Even now that I type this question out I'm thinking I should take a different approach. My code places a 0 at each blank line and I currently have it set to place a 0 on the line above the 1st 1. With that, I could maybe find the 1st 0 then add all the 1's till i reach a 2 then find the next 0 and so forth. Does that make sense?
Below is a picture of what the macro is currently producing.
You can actually do this with a formula
=IF(P3=2,SUMIF($P$1:P2,1,$K$1:K2)-SUMIF($P$1:P2,2,$K$1:K2),"")
in each cell in K where there is a 2 in column P. Could use VBA to insert this.
Here's a straight VBA solution:
Sub x()
Dim r As Range
For Each r In Range("K:K").SpecialCells(xlCellTypeConstants).Areas
r(r.Count + 1).Value = Application.Sum(r)
Next r
End Sub